/[projects]/dao/DelphiScanner/Components/tpsystools_4.04/examples/Delphi/AstCalU.pas
ViewVC logotype

Annotation of /dao/DelphiScanner/Components/tpsystools_4.04/examples/Delphi/AstCalU.pas

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2671 - (hide annotations) (download)
Tue Aug 25 18:15:15 2015 UTC (8 years, 10 months ago) by torben
File size: 12803 byte(s)
Added tpsystools component
1 torben 2671 (* ***** BEGIN LICENSE BLOCK *****
2     * Version: MPL 1.1
3     *
4     * The contents of this file are subject to the Mozilla Public License Version
5     * 1.1 (the "License"); you may not use this file except in compliance with
6     * the License. You may obtain a copy of the License at
7     * http://www.mozilla.org/MPL/
8     *
9     * Software distributed under the License is distributed on an "AS IS" basis,
10     * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
11     * for the specific language governing rights and limitations under the
12     * License.
13     *
14     * The Original Code is TurboPower SysTools
15     *
16     * The Initial Developer of the Original Code is
17     * TurboPower Software
18     *
19     * Portions created by the Initial Developer are Copyright (C) 1996-2002
20     * the Initial Developer. All Rights Reserved.
21     *
22     * Contributor(s):
23     *
24     * ***** END LICENSE BLOCK ***** *)
25    
26     unit AstCalU;
27    
28     interface
29    
30     uses
31     SysUtils, Windows, Classes, Graphics, Controls,
32     Forms, Dialogs, StdCtrls, ExtCtrls,
33    
34     StConst,
35     StDate,
36     StDateSt,
37     StAstro,
38     StAstroP;
39    
40    
41     type
42     TForm1 = class(TForm)
43     Panel1: TPanel;
44     Label1: TLabel;
45     Button1: TButton;
46     Label2: TLabel;
47     Label3: TLabel;
48     MonthEF: TEdit;
49     DateEF: TEdit;
50     YearEF: TEdit;
51     Label4: TLabel;
52     Label5: TLabel;
53     Label6: TLabel;
54     GB1: TGroupBox;
55     Label7: TLabel;
56     Label8: TLabel;
57     LocalTimeEF: TEdit;
58     SiderealTimeEF: TEdit;
59     GB2: TGroupBox;
60     Label9: TLabel;
61     Label10: TLabel;
62     Label11: TLabel;
63     Label12: TLabel;
64     Label13: TLabel;
65     SunRiseEF: TEdit;
66     MoonRiseEF: TEdit;
67     SunSetEF: TEdit;
68     MoonSetEF: TEdit;
69     TwiStartEF: TEdit;
70     TwiEndEF: TEdit;
71     GB3: TGroupBox;
72     PositionsLB: TListBox;
73     Header1: THeader;
74     GB4: TGroupBox;
75     NMFirstDate: TEdit;
76     FQFirstDate: TEdit;
77     NMFirstTime: TEdit;
78     FQFirstTime: TEdit;
79     FMFirstDate: TEdit;
80     LQFirstDate: TEdit;
81     LQFirstTime: TEdit;
82     FMFirstTime: TEdit;
83     Label14: TLabel;
84     Label15: TLabel;
85     Label16: TLabel;
86     Label17: TLabel;
87     NMSecondDate: TEdit;
88     NMSecondTime: TEdit;
89     FQSecondDate: TEdit;
90     FQSecondTime: TEdit;
91     FMSecondDate: TEdit;
92     FMSecondTime: TEdit;
93     LQSecondTime: TEdit;
94     LQSecondDate: TEdit;
95     NMPrevDate: TEdit;
96     FQPrevDate: TEdit;
97     FMPrevDate: TEdit;
98     LQPrevDate: TEdit;
99     LQPrevTime: TEdit;
100     FMPrevTime: TEdit;
101     FQPrevTime: TEdit;
102     NMPrevTime: TEdit;
103     NMNextDate: TEdit;
104     FQNextDate: TEdit;
105     FMNextDate: TEdit;
106     LQNextDate: TEdit;
107     LQNextTime: TEdit;
108     FMNextTime: TEdit;
109     FQNextTime: TEdit;
110     NMNextTime: TEdit;
111     Header2: THeader;
112     GB5: TGroupBox;
113     Label18: TLabel;
114     Label19: TLabel;
115     Label20: TLabel;
116     Label21: TLabel;
117     Label22: TLabel;
118     SpringTime: TEdit;
119     SummerTime: TEdit;
120     SummerDate: TEdit;
121     SpringDate: TEdit;
122     FallTime: TEdit;
123     WinterTime: TEdit;
124     WinterDate: TEdit;
125     FallDate: TEdit;
126     EasterEF: TEdit;
127     PhaseLabel: TLabel;
128     Label23: TLabel;
129     SunlightEF: TEdit;
130     LongEF: TEdit;
131     LatEF: TEdit;
132     Timer1: TTimer;
133     procedure Button1Click(Sender: TObject);
134     procedure FormCreate(Sender: TObject);
135     procedure Timer1Timer(Sender: TObject);
136     private
137     { Private declarations }
138     public
139     { Public declarations }
140    
141     TheDT : TStDateTimeRec;
142     RS : TStRiseSetRec;
143    
144     D, M, Y : Integer;
145    
146     ObsLat,
147     ObsLong : Double;
148    
149     procedure DoCalcTimes;
150     procedure DoFixedCalcs;
151     procedure DoCalcs(ObsLong, ObsLat : Double);
152    
153     end;
154    
155     var
156     Form1: TForm1;
157    
158    
159     implementation
160    
161     {$R *.DFM}
162    
163    
164     procedure TForm1.DoCalcTimes;
165     var
166     TT : TStTime;
167     begin
168     LocalTimeEF.Text := CurrentTimeString('hh:mm:ss', False);
169     TheDT.T := CurrentTime;
170     TT := Round(SiderealTime(TheDT) * 240);
171     SiderealTimeEF.Text := StTimeToTimeString('hh:mm:ss', TT, False);
172     end;
173    
174    
175     procedure TForm1.DoFixedCalcs;
176     var
177     Y,
178     M ,
179     D : integer;
180     DTR : TStDateTimeRec;
181     MPR : TStMoonPosRec;
182     SPR : TStPosRec;
183     LR : TStLunarRecord;
184     PA : TStPlanetsArray;
185    
186     begin
187    
188     {Calculate Positions}
189    
190     SPR := SunPos(TheDT);
191     PositionsLB.Items.Add('Sun ' + HoursMin(SPR.RA) + ' ' + DegsMin(SPR.DC));
192    
193     MPR := MoonPos(TheDT);
194     PositionsLB.Items.Add('Moon ' + HoursMin(MPR.RA) + ' ' + DegsMin(MPR.DC));
195    
196     PlanetsPos(AstJulianDate(TheDT.D) + TheDT.T/86400, PA);
197     PositionsLB.Items.Add('Mercury ' + HoursMin(PA[1].RA) + ' ' + DegsMin(PA[1].DC));
198     PositionsLB.Items.Add('Venus ' + HoursMin(PA[2].RA) + ' ' + DegsMin(PA[2].DC));
199     PositionsLB.Items.Add('Mars ' + HoursMin(PA[3].RA) + ' ' + DegsMin(PA[3].DC));
200     PositionsLB.Items.Add('Jupiter ' + HoursMin(PA[4].RA) + ' ' + DegsMin(PA[4].DC));
201     PositionsLB.Items.Add('Saturn ' + HoursMin(PA[5].RA) + ' ' + DegsMin(PA[5].DC));
202     PositionsLB.Items.Add('Uranus ' + HoursMin(PA[6].RA) + ' ' + DegsMin(PA[6].DC));
203     PositionsLB.Items.Add('Neptune ' + HoursMin(PA[7].RA) + ' ' + DegsMin(PA[7].DC));
204     PositionsLB.Items.Add('Pluto ' + HoursMin(PA[8].RA) + ' ' + DegsMin(PA[8].DC));
205    
206    
207     {Calculate lunar phases}
208    
209     if LunarPhase(TheDT) >= 0 then
210     PhaseLabel.Caption := 'Waxing'
211     else
212     PhaseLabel.Caption := 'Waning';
213    
214    
215     LR := NewMoon(TheDT.D);
216     NMFirstDate.Text := StDateToDateString('mm/dd', LR.T[0].D, False);
217     NMFirstTime.Text := StTimeToTimeString('hh:mm', LR.T[0].T, False);
218     if LR.T[1].D <> BadDate then
219     begin
220     NMSecondDate.Text := StDateToDateString('mm/dd', LR.T[1].D, False);
221     NMSecondTime.Text := StTimeToTimeString('hh:mm', LR.T[1].T, False);
222     end else
223     begin
224     NMSecondDate.Text := '';
225     NMSecondTime.Text := '';
226     end;
227    
228     LR := FirstQuarter(TheDT.D);
229     FQFirstDate.Text := StDateToDateString('mm/dd', LR.T[0].D, False);
230     FQFirstTime.Text := StTimeToTimeString('hh:mm', LR.T[0].T, False);
231     if LR.T[1].D <> BadDate then
232     begin
233     FQSecondDate.Text := StDateToDateString('mm/dd', LR.T[1].D, False);
234     FQSecondTime.Text := StTimeToTimeString('hh:mm', LR.T[1].T, False);
235     end else
236     begin
237     FQSecondDate.Text := '';
238     FQSecondTime.Text := '';
239     end;
240    
241     LR := FullMoon(TheDT.D);
242     FMFirstDate.Text := StDateToDateString('mm/dd', LR.T[0].D, False);
243     FMFirstTime.Text := StTimeToTimeString('hh:mm', LR.T[0].T, False);
244     if LR.T[1].D <> BadDate then
245     begin
246     FMSecondDate.Text := StDateToDateString('mm/dd', LR.T[1].D, False);
247     FMSecondTime.Text := StTimeToTimeString('hh:mm', LR.T[1].T, False);
248     end else
249     begin
250     FMSecondDate.Text := '';
251     FMSecondTime.Text := '';
252     end;
253    
254     LR := LastQuarter(TheDT.D);
255     LQFirstDate.Text := StDateToDateString('mm/dd', LR.T[0].D, False);
256     LQFirstTime.Text := StTimeToTimeString('hh:mm', LR.T[0].T, False);
257     if LR.T[1].D <> BadDate then
258     begin
259     LQSecondDate.Text := StDateToDateString('mm/dd', LR.T[1].D, False);
260     LQSecondTime.Text := StTimeToTimeString('hh:mm', LR.T[1].T, False);
261     end else
262     begin
263     LQSecondDate.Text := '';
264     LQSecondTime.Text := '';
265     end;
266    
267    
268     {Calculate Next/Previous}
269    
270     DTR := PrevNewMoon(TheDT.D);
271     if DTR.D <> BadDate then
272     begin
273     NMPrevDate.Text := StDateToDateString('mm/dd', DTR.D, False);
274     NMPrevTime.Text := StTimeToTimeString('hh:mm', DTR.T, False);
275     end else
276     begin
277     NMPrevDate.Text := '';
278     NMPrevTime.Text := '';
279     end;
280    
281     DTR := NextNewMoon(TheDT.D);
282     if DTR.D <> BadDate then
283     begin
284     NMNextDate.Text := StDateToDateString('mm/dd', DTR.D, False);
285     NMNextTime.Text := StTimeToTimeString('hh:mm', DTR.T, False);
286     end else
287     begin
288     NMNextDate.Text := '';
289     NMNextTime.Text := '';
290     end;
291    
292    
293     DTR := PrevFirstQuarter(TheDT.D);
294     if DTR.D <> BadDate then
295     begin
296     FQPrevDate.Text := StDateToDateString('mm/dd', DTR.D, False);
297     FQPrevTime.Text := StTimeToTimeString('hh:mm', DTR.T, False);
298     end else
299     begin
300     FQPrevDate.Text := '';
301     FQPrevTime.Text := '';
302     end;
303    
304     DTR := NextFirstQuarter(TheDT.D);
305     if DTR.D <> BadDate then
306     begin
307     FQNextDate.Text := StDateToDateString('mm/dd', DTR.D, False);
308     FQNextTime.Text := StTimeToTimeString('hh:mm', DTR.T, False);
309     end else
310     begin
311     FQNextDate.Text := '';
312     FQNextTime.Text := '';
313     end;
314    
315    
316     DTR := PrevFullMoon(TheDT.D);
317     if DTR.D <> BadDate then
318     begin
319     FMPrevDate.Text := StDateToDateString('mm/dd', DTR.D, False);
320     FMPrevTime.Text := StTimeToTimeString('hh:mm', DTR.T, False);
321     end else
322     begin
323     FMPrevDate.Text := '';
324     FMPrevTime.Text := '';
325     end;
326    
327     DTR := NextFullMoon(TheDT.D);
328     if DTR.D <> BadDate then
329     begin
330     FMNextDate.Text := StDateToDateString('mm/dd', DTR.D, False);
331     FMNextTime.Text := StTimeToTimeString('hh:mm', DTR.T, False);
332     end else
333     begin
334     FMNextDate.Text := '';
335     FMNextTime.Text := '';
336     end;
337    
338    
339     DTR := PrevLastQuarter(TheDT.D);
340     if DTR.D <> BadDate then
341     begin
342     LQPrevDate.Text := StDateToDateString('mm/dd', DTR.D, False);
343     LQPrevTime.Text := StTimeToTimeString('hh:mm', DTR.T, False);
344     end else
345     begin
346     LQPrevDate.Text := '';
347     LQPrevTime.Text := '';
348     end;
349    
350     DTR := NextLastQuarter(TheDT.D);
351     if DTR.D <> BadDate then
352     begin
353     LQNextDate.Text := StDateToDateString('mm/dd', DTR.D, False);
354     LQNextTime.Text := StTimeToTimeString('hh:mm', DTR.T, False);
355     end else
356     begin
357     LQNextDate.Text := '';
358     LQNextTime.Text := '';
359     end;
360    
361    
362     {Calculate Other Events}
363    
364     StDateToDMY(TheDT.D, D, M, Y);
365     EasterEF.Text := StDateToDateString('mm/dd', Easter(Y, 0), False);
366    
367    
368     DTR := Equinox(Y, 0, True);
369     SpringDate.Text := StDateToDateString('mm/dd', DTR.D, False);
370     SpringTime.Text := StTimeToTimeString('hh:mm', DTR.T, False);
371    
372    
373     DTR := Equinox(Y, 0, False);
374     FallDate.Text := StDateToDateString('mm/dd', DTR.D, False);
375     FallTime.Text := StTimeToTimeString('hh:mm', DTR.T, False);
376    
377    
378     DTR := Solstice(Y, 0, True);
379     SummerDate.Text := StDateToDateString('mm/dd', DTR.D, False);
380     SummerTime.Text := StTimeToTimeString('hh:mm', DTR.T, False);
381    
382    
383     DTR := Solstice(Y, 0, False);
384     WinterDate.Text := StDateToDateString('mm/dd', DTR.D, False);
385     WinterTime.Text := StTimeToTimeString('hh:mm', DTR.T, False);
386     end;
387    
388    
389    
390     procedure TForm1.DoCalcs(ObsLong, ObsLat : Double);
391     begin
392     SunlightEF.Text := StTimeToTimeString('hh:mm',
393     AmountOfSunlight(TheDT.D, ObsLong, ObsLat), False);
394    
395    
396     RS := SunRiseSet(TheDT.D, ObsLong, ObsLat);
397     SunRiseEF.Text := StTimeToTimeString('hh:mm', RS.ORise, False);
398     SunSetEF.Text := StTimeToTimeString('hh:mm', RS.OSet, False);
399    
400     RS := MoonRiseSet(TheDT.D, ObsLong, ObsLat);
401     MoonRiseEF.Text := StTimeToTimeString('hh:mm', RS.ORise, False);
402     MoonSetEF.Text := StTimeToTimeString('hh:mm', RS.OSet, False);
403    
404     RS := Twilight(TheDT.D, ObsLong, ObsLat, ttAstronomical);
405     TwiStartEF.Text := StTimeToTimeString('hh:mm', RS.ORise, False);
406     TwiEndEF.Text := StTimeToTimeString('hh:mm', RS.OSet, False);
407     end;
408    
409    
410     procedure TForm1.Button1Click(Sender: TObject);
411     begin
412     try
413     M := StrToInt(MonthEF.Text);
414     if not (M in [1..12]) then
415     begin
416     ShowMessage('Month value out of range (1..12)');
417     Exit;
418     end;
419    
420     D := StrToInt(DateEF.Text);
421     if not (D in [1..31]) then
422     begin
423     ShowMessage('Date value out of range (1..31)');
424     Exit;
425     end;
426    
427     Y := StrToInt(YearEF.Text);
428     if (Y < 1800) or (Y > 2200) then
429     begin
430     ShowMessage('Year value out of range (1800..2200)');
431     Exit;
432     end;
433    
434     TheDT.D := DMYToStDate(D, M, Y, 0);
435     if TheDT.D = BadDate then
436     begin
437     ShowMessage('Invalid date');
438     Exit;
439     end;
440     TheDT.T := CurrentTime;
441    
442     ObsLong := StrToFloat(LongEF.Text);
443     if (ObsLong < -180) or (ObsLong > 180) then
444     begin
445     ShowMessage('Longitude out of range (-180..180)');
446     Exit;
447     end;
448    
449     ObsLat := StrToFloat(LatEF.Text);
450     if (ObsLat < -90) or (ObsLat > 90) then
451     begin
452     ShowMessage('Latitude out of range (-90..90)');
453     Exit;
454     end;
455    
456     PositionsLB.Clear;
457     DoFixedCalcs;
458     DoCalcs(ObsLong, ObsLat);
459    
460     except
461     ShowMessage('One or more entry fields has illegal data');
462     end;
463     end;
464    
465     procedure TForm1.FormCreate(Sender: TObject);
466     begin
467     TheDT.D := CurrentDate;
468     TheDT.T := CurrentTime;
469    
470     StDateToDMY(TheDT.D, D, M, Y);
471     MonthEF.Text := IntToStr(M);
472     DateEF.Text := IntToStr(D);
473     YearEF.Text := IntToStr(Y);
474    
475     LongEF.Text := FloatToStr(-105.27);
476     LatEF.Text := FloatToStr(38.87);
477    
478     DoCalcTimes;
479     Button1Click(Button1);
480     end;
481    
482     procedure TForm1.Timer1Timer(Sender: TObject);
483     begin
484     DoCalcTimes;
485     end;
486    
487     end.

  ViewVC Help
Powered by ViewVC 1.1.20