This program displays the moon phase for any calendar date (after 1582 since it does not use a Julian calendar correction).
The program has a simple interactive GUI with three windows. You can enter a date and navigate back/forth through the lunar calendar.
The starry night is animated with a simple trick using a PRNG with two seed counters, one that runs ahead of the other where the first turns a random star on and the other that runs behind turns a star off. Other routines that can be useful are the rounded box drawing and date conversion routines.
The code is written for the Maximite and Colour Maximite and can be run in any color mode, the windows and graphics adjust.
This is freeware.
Enjoy!
' MOON.BAS v1.0
' Displays the moon phase for any date after 1582
' For Maximite and Colour Maximite
' This is freeware
' Robert van Engelen, 2018
' fetch current date
d$ = DATE$
CLS
FONT 1,1,0
PRNG.seed(prn1)
maxstars = 80
state = 0
' CMM: use color with the current resolution and define background color bg
bg = 0
IF MM.DEVICE$ = "Colour Maximite" THEN COLOR 7: bg = 1
w = MM.HRES: h = MM.VRES
' set window sizes
w2 = w/4: w3 = w-w2: h1 = h/6: h2 = h-h1
DO ' loop until quit
' draw windows
DrawBox 1,1,w-2,h1-2,7,0,8
DrawBox 1,h1+1,w2-2,h2-2,7,bg,8
DrawBox w2+1,h1+1,w3-2,h2-2,7,0,8
PRINT @(8,8) "Welcome to the lunar calendar"
PRINT @(8,20) "Date: ";
PRINT WeekDay$(d$);" ";Month$(d$);" ";Day$(d$);", ";RIGHT$(d$,4)
' compute phase
d = Days(d$)+19
p = d/29.530588
p = p-INT(p)
phase = 4*p
' display moon phase
CenterTitle 0,h1+8,w2,bg,MoonPhase$(phase)
DrawMoon w2\2,h1+w2,w2\3,7,bg,phase
CenterTitle 0,h1+w2+w2\3+20,w2,bg,"View from Earth"
DrawEarthMoonSun w2+w3\2-h2\4,h1+h2\2,h2\16,phase
' use a PRNG sequence to twinkle the night sky, no array needed
stars = 0
prn2 = prn1
DO ' loop until screen update needed
DO ' loop until key press
' turn a star on
x = w2+3+(prn1 MOD (w3-5))
PRNG.update prn1
y = h1+3+(prn1 MOD (h2-5))
PRNG.update prn1
IF x+y AND 7 THEN
PIXEL(x,y) = -1
ELSE
LINE (x-1,y)-(x+1,y),-1
LINE (x,y-1)-(x,y+1),-1
ENDIF
' turn a star off when maxstars painted
IF stars = maxstars THEN
PAUSE 200
x = w2+3+(prn2 MOD (w3-5))
PRNG.update prn2
y = h1+3+(prn2 MOD (h2-5))
PRNG.update prn2
IF x+y AND 7 THEN
PIXEL(x,y) = -1
ELSE
LINE (x-1,y)-(x+1,y),-1
LINE (x,y-1)-(x,y+1),-1
ENDIF
ELSE
stars = stars+1
ENDIF
key = ASC(INKEY$)
LOOP UNTIL key
IF key = 27 OR key = ASC("q") OR key = ASC("Q") THEN END
IF state <= 1 THEN
IF key = ASC("d") OR key = ASC("D") THEN
PRINT @(8,20) "Enter date: DD-MM-YYYY ";
d$ = ""
state = 2
ELSEIF key = ASC("n") OR key = ASC("N") THEN
NextDay d$
state = 0
ELSEIF key = ASC("p") OR key = ASC("P") THEN
PrevDay d$
state = 0
ELSEIF key = ASC("s") OR key = ASC("S") THEN
SAVEBMP "MOONDUMP.BMP"
state = 0
ELSE
PRINT @(8,20) "q)uit d)ate n)ext p)rev s)ave "
state = 1
ENDIF
ELSEIF key >= ASC("0") AND key <= ASC("9") THEN
d$ = d$+CHR$(key)
state = state+1
IF state = 4 THEN d$ = d$+"-": state = 5
IF state = 7 THEN d$ = d$+"-": state = 8
IF state = 12 THEN state = 0
FONT 1,1,1: PRINT @(80,20) d$: FONT 1,1,0
ENDIF
LOOP UNTIL state = 0
LOOP
' seed the PRNG
SUB PRNG.seed(prn)
prn = TIMER
END SUB
' update PRNG using Lehmer LCG
SUB PRNG.update(prn)
LOCAL k
k = prn\127773
prn = 16807*(prn-127773*k)-2836*k
IF prn <= 0 THEN prn = prn+&h7FFFFFFF
END SUB
' put a title t$ at (x,y) centered at width w background b
SUB CenterTitle(x,y,w,b,t$)
LOCAL i,j,k,n
n = LEN(t$)
IF 6*n < w THEN
PRINT @(x+w\2-3*n,y) CHR$(192+b);t$;CHR$(192)
ELSE
i = 1: k = 0
DO
j = INSTR(i,t$," ")
IF j = 0 THEN j = n+1
PRINT @(x+w\2-3*(j-i),y+k) CHR$(192+b);MID$(t$,i,j-i);CHR$(192)
i = j+1: k = k+12
LOOP UNTIL i > n
ENDIF
END SUB
' draw rounded box at x,y to x+w,y+h color c background b corner radius r
SUB DrawBox(x,y,w,h,c,b,r)
IF r > 0 THEN
CIRCLE (x+r,y+r),r,b,F
CIRCLE (x+r,y+r),r,c
CIRCLE (x+w-r,y+r),r,b,F
CIRCLE (x+w-r,y+r),r,c
CIRCLE (x+w-r,y+h-r),r,b,F
CIRCLE (x+w-r,y+h-r),r,c
CIRCLE (x+r,y+h-r),r,b,F
CIRCLE (x+r,y+h-r),r,c
LINE (x+r,y)-(x+w-r,y+h),b,BF
LINE (x,y+r)-(x+w,y+h-r),b,BF
LINE (x+r,y)-(x+w-r,y),c
LINE (x+w,y+r)-(x+w,y+h-r),c
LINE (x+r,y+h)-(x+w-r,y+h),c
LINE (x,y+r)-(x,y+h-r),c
ELSE
LINE (x,y)-(x+w,y+h),b,BF
LINE (x,y)-(x+w,y+h),c,B
ENDIF
END SUB
' returns the moon phase for phase 0<=p<=4
FUNCTION MoonPhase$(p)
IF p < 0.1 THEN
MoonPhase$ = "New"
ELSEIF p < 0.9 THEN
MoonPhase$ = "Waxing Crescent"
ELSEIF p < 1.1 THEN
MoonPhase$ = "First Quarter"
ELSEIF p < 1.9 THEN
MoonPhase$ = "Waxing Gibbous"
ELSEIF p < 2.1 THEN
MoonPhase$ = "Full"
ELSEIF p < 2.9 THEN
MoonPhase$ = "Waning Gibbous"
ELSEIF p < 3.1 THEN
MoonPhase$ = "Third Quarter"
ELSEIF p < 3.9 THEN
MoonPhase$ = "Waning Crescent"
ELSE
MoonPhase$ = "New"
ENDIF
END FUNCTION
' draw a moon at (x,y) with radius r color c background b and phase 0<=p<=4
SUB DrawMoon(x,y,r,c,b,p)
LOCAL d1,d2
d1 = .833*SIN((p-1)*PI/2)
d2 = .833*SIN((1-p)*PI/2)
CIRCLE (x,y),r,c,.833,F
IF p < 1 THEN
LINE (x-r,y-r)-(x-1,y+r),b,BF
CIRCLE (x,y),r,b,d2,F
ELSEIF p < 2 THEN
LINE (x-r,y-r)-(x-1,y+r),b,BF
CIRCLE (x,y),r,c,d1,F
ELSEIF p < 3 THEN
LINE (x+1,y-r)-(x+r,y+r),b,BF
CIRCLE (x,y),r,c,d2,F
ELSE
LINE (x+1,y-r)-(x+r,y+r),b,BF
CIRCLE (x,y),r,b,d1,F
ENDIF
END SUB
' draw earth, sun and moon at (x,y) with radius r and phase 0<=p<=4
SUB DrawEarthMoonSun(x,y,r,p)
LOCAL d1,d2
d1 = 4*r*COS(p*PI/2)*.833
d2 = -4*r*SIN(p*PI/2)
CIRCLE (x,y),4*r,1,.833
CIRCLE (x+8*r,y),r,6,.833,F
CIRCLE (x,y),r,1,.833,F
CIRCLE (x,y-r/3),r/4,2,2,F
CIRCLE (x-r/6,y+r/4),r/3,2,F
CIRCLE (x,y-r+r/12),r/12,7,1.5,F
CIRCLE (x,y+r-r/10),r/10,7,2,F
LINE (x-r,y-r)-(x-1,y+r),0,BF
CIRCLE (x+d1,y+d2),r/4,7,.833,F
LINE (x+d1-r/4,y+d2-r/4)-(x+d1-1,y+d2+r/4),0,BF
END SUB
' return days since 01-01-0001 without Julian calendar correction
FUNCTION Days(d$)
LOCAL d,m,y,a
d = VAL(MID$(d$,1,2))
m = VAL(MID$(d$,4,2))
y = VAL(MID$(d$,7,4))
a = INT((14-m)/12)
m = m+12*a
y = y-a
Days = 365*y+INT(y/4)-INT(y/100)+INT(y/400)+INT((153*m-457)/5)+d-306
END FUNCTION
' return the weekday of the given date
FUNCTION WeekDay$(d$)
LOCAL d,w$
d = 7*(Days(d$) MOD 7)+1
w$ = "Sun Mon Tues Wednes Thurs Fri Satur "
WeekDay$ = MID$(w$,d,INSTR(d,w$," ")-d)+"day"
END FUNCTION
' return the day of the month of the given date
FUNCTION Day$(d$)
LOCAL z
z = ASC(d$)=48
Day$ = MID$(d$,1+z,2-z)
END FUNCTION
' return the month of the given date
FUNCTION Month$(d$)
LOCAL m,m$
m = 10*VAL(MID$(d$,4,2))-9
m$ = "January February March April May June "
m$ = m$+"July August September October November December "
Month$ = MID$(m$,m,INSTR(m,m$," ")-m)
END FUNCTION
' update date d$ to next day
SUB NextDay(d$)
LOCAL d,m,y,a
d = VAL(MID$(d$,1,2))+1
m = VAL(MID$(d$,4,2))
y = VAL(MID$(d$,7,4))
a = y MOD 4 = 0 AND (y MOD 100 <> 0 OR y MOD 400 = 0)
IF d > 31 OR ((m+(m>7)) MOD 2 = 0 AND d > 30) OR (m = 2 AND d > 28+a) THEN
d = 1: m = m+1: IF m > 12 THEN m = 1: y = y+1
ENDIF
d$ = FORMAT$(d,"%02g")+"-"+FORMAT$(m,"%02g")+"-"+FORMAT$(y,"%04g")
END SUB
' update date d$ to previous day
SUB PrevDay(d$)
LOCAL d,m,y,a
d = VAL(MID$(d$,1,2))-1
m = VAL(MID$(d$,4,2))
y = VAL(MID$(d$,7,4))
a = y MOD 4 = 0 AND (y MOD 100 <> 0 OR y MOD 400 = 0)
IF d < 1 THEN
m = m-1: IF m < 1 THEN m = 12: y = y-1
d = 31-((m+(m>7)) MOD 2 = 0)
IF m = 2 THEN d = 28+a
ENDIF
d$ = FORMAT$(d,"%02g")+"-"+FORMAT$(m,"%02g")+"-"+FORMAT$(y,"%04g")
END SUB