===MOON.BAS lunar calendar with graphics and simple GUI=== {{ :migratedattachments:mmbasic_original:moon.bas.zip?linkonly}} {{ :migratedattachments:mmbasic_original:moondump_bmp.zip?linkonly}} 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