User Tools

Site Tools


mmbasic:moon_bas_lunar_calendar_with_graphics_and_simple_gui

MOON.BAS lunar calendar with graphics and simple GUI

moon.bas.zip moondump_bmp.zip

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
mmbasic/moon_bas_lunar_calendar_with_graphics_and_simple_gui.txt · Last modified: 2024/01/19 09:30 by 127.0.0.1