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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2671 - (show annotations) (download)
Tue Aug 25 18:15:15 2015 UTC (8 years, 9 months ago) by torben
File size: 12803 byte(s)
Added tpsystools component
1 (* ***** 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