NORM%IONAACAD.BITNET@CUNYVM.CUNY.EDU (Norman Walsh) (03/11/91)
Several weeks (months?) ago someone posted a directory of routines for
displaying the phase of the moon. I humbly apologize for forgetting
who the original author was. I have taken the liberty of making some
modifications, but I do NOT take any credit for the real guts of the
routines. Any bugs in this posting should be considered my fault, not
the original poster's...
I have made basically two changes. First, I have made it possible to
plot the phase of the moon for any date (not just today) and I have
added the ability to plot the phase of the moon over the course of
a month (again, for any date). I don't know the limitations of the
moon phase calculations so I can't say for sure how wide a range of
dates can reasonably be expected to work accurately.
The following entry points are provided in a custom menu:
FRAC - displays the percent of illumination and age of the moon
AGE - displays the age of the moon and % illuminated (not quite
the same as FRAC).
SHOW - draws the lunar face.
GRAF - plots the phase of the moon over the course of the month.
>DATE - changes the moon phase date. Expects a valid date in level 1
of the stack. Uses system date if the stack is empty.
>TIME - changes the moon phase time. Expects a valid time in level 1
of the stack. Uses system time if the stack is empty.
MCLK - displays the current DATE and TIME.
If you would like more information about the actual programs in the
directory, just give a yell.
ndw
%%HP: T(3)A(D)F(.);
DIR
CST { { "FRAC"
\<< MFRAC
\>> } { "AGE"
MTIME } { "SHOW"
MPHASE } { "GRAF"
MGRAPH } { ">DATE"
\<<
IF DEPTH 0 ==
THEN DATE
END 'PDATE'
STO
IFERR 'PTIME'
RCL
THEN 0
'PTIME' STO
END DROP
\>> } { ">TIME"
\<<
IF DEPTH 0 ==
THEN TIME
END 'PTIME'
STO
\>> } { "MCLK"
\<< PDATE "Date"
\->TAG PTIME "Time"
\->TAG
\>> } }
EQ M.EQ
GETDATE
\<<
IF DEPTH 0 ==
THEN
"Put MM.DDYYYY on stk"
DOERR
END
IF DEPTH 1 ==
THEN TIME
END \-> date
time
\<< date DUP IP
0 > SWAP DUP IP 13
< SWAP FP 100 * IP
32 < AND AND
IF NOT
THEN
"Invalid date"
ELSE time
'PTIME' STO date
'PDATE' STO
END
\>>
\>>
JDAT
\<< 1.01198 PDATE
DDAYS 2444240 +
PTIME HMS\-> TMZN +
24 / +
\>>
LBL
\<< \-> x y lbl
\<< PICT x R\->B
y R\->B 2 \->LIST lbl 1
\->GROB GXOR
\>>
\>>
M.EQ
\<< PDATE DUP IP
SWAP 100 * FP 100 /
+ X IP 100 / +
'PDATE' STO X FP 24
* 'PTIME' STO MBASE
MB\->I
\>>
MBASE
\<< 0 0 0 0 0 0
JDAT 2444239 - \-> M
ML MM EV AE A3 day
\<< RAD day
.985647332099 * 360
MOD -3.762863 + 360
MOD D\->R 'M' STO 'E=
.016718*SIN(E)+M'
'E' M ROOT 2 / TAN
1.01686011182 *
ATAN R\->D 2 *
282.596403 + 360
MOD 'E' STO
13.1763966 day *
64.975464 + 360 MOD
DUP 'ML' STO
.1114041 day * -
349.383063 - 360
MOD 'MM' STO ML E -
2 * MM - D\->R SIN
1.2739 * 'EV' STO M
SIN DUP .1858 *
'AE' STO .37 * 'A3'
STO MM EV + AE - A3
- DUP D\->R SIN
6.2886 * SWAP 2 *
D\->R SIN .214 * SWAP
EV + ML + AE - +
DUP E - 2 * D\->R SIN
.6583 * + E -
\>>
\>>
MB\->A
\<< 360 MOD 360 /
\>>
MB\->I
\<< D\->R COS NEG 1
+ 2 /
\>>
MDIR
\<< MFRST RCLF
MBASE MB\->I PDATE 1
DATE+ 'PDATE' STO
MBASE MB\->I ROT STOF
IF DUP2 <
THEN DROP
ELSE DROP NEG
END
\>>
MFRAC
\<<
IFERR 'PDATE'
RCL
THEN DROP
DATE TIME GETDATE
ELSE DROP
END RCLF
MBASE DUP MB\->I
'Illuminated' \->TAG
SWAP MB\->A 'Age'
\->TAG ROT STOF 'E'
PURGE
\>>
MFRST
\<< PDATE DUP IP
SWAP 100 * FP 1 +
100 / + 'PDATE' STO
\>>
MGRAPH
\<<
"Calculating month len"
1 DISP
"and initial lunar pos"
2 DISP
IFERR 'PDATE'
RCL
THEN DROP
DATE TIME GETDATE
ELSE DROP
END { (1,-.1)
} PDATE NXTMTH -1
DATE+ FP 100 * IP
1.1 R\->C 1 \->LIST + {
X } + \GDDAY 1 \->LIST
+ { (0,0) FUNCTION
Y } + 'PPAR' STO
'M.EQ' 'EQ' STO
ERASE 5 MDIR
CASE DUP DUP
ABS .8 > SWAP 0 <
AND
THEN 54
END DUP DUP
ABS .2 < SWAP 0 <
AND
THEN 5
END DUP 0 <
THEN 5
END 54
END SWAP DROP
PDATE DUP IP \->STR
"/" + SWAP 100 * FP
10000 *
IF DUP 100 /
IP 19 ==
THEN 100 / FP
100 *
END \->STR +
LBL RCLF DRAW TCKS
STOF 'E' PURGE 7
FREEZE
\>>
MLINE
\<< \-> SC LI L R
\<< SC L * 64 +
R\->B LI R\->B 2 \->LIST
SC R * 64 + R\->B LI
R\->B 2 \->LIST LINE
\>>
\>>
MPHASE
\<< RCLF -31 SF
DEG ERASE { # 0d
# 0d } PVIEW {
# 64d # 28d } # 26d
0 360 ARC 26 28
MFRAC SWAP DROP
MPLOT PICT NEG 5 54
PDATE \->STR LBL 100
54 PTIME 4 FIX \->STR
LBL 7 FREEZE STOF
\>>
MPLOT
\<< \-> RA MI F
\<<
IF F .5 <
THEN F 360
* COS RA * RA
ELSE RA NEG
F .5 - 360 * COS RA
*
END \-> L R
\<< 1 0
FOR x x
ACOS SIN DUP MI x
RA * + L R MLINE MI
x RA * - L R MLINE
RA INV NEG
STEP
\>>
\>>
\>>
MTIME
\<< MFRAC \-> PCT X
\<< X
29.53058868 * DUP
'X' STO IP "d " + X
FP 24 * IP + "h " +
X FP 1440 * 60 MOD
IP + "m (" + PCT
100 * 0 RND + "%)"
+
\>>
\>>
NXTMTH
\<< 1 +
IF DUP IP 12
>
THEN 12 -
.000001 +
END DUP IP
SWAP 100 * FP 100 /
.01 + +
\>>
PDATE 3.311991
PPAR { (1,-.1)
(31,1.1) X .5 (0,0)
FUNCTION Y }
PTIME 0
TCKS
\<< { # 0d # 63d
} { # 130d # 63d }
LINE PPAR 2 GET
OBJ\-> DROP 1 SWAP
FOR d d -.05
R\->C C\->PX OBJ\-> DROP
DROP # 62d 2 \->LIST
PIXON
NEXT
\>>
\GDDAY .5
END
***END OF POSTING***