MOON.BAS lunar calendar with graphics and simple GUI

' 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