' CALENDAR.BAS - a multi-language calendar routine
' Author       : Egbert Zijlema (E.Zijlema@uni4nn.iaf.nl)
' (up)Date     : 9 January 1997 (Julian 2450458)
' Status       : Public Domain
' Compiler     : Power Basic 3.2 for DOS

' CALENDAR.BAS displays a (browsable) monthly calendar and the
' dates of the celebration days for a given year.

' Screen text is either in English, German or Dutch, which depends
' of a correct COUNTRY setting in your CONFIG.SYS file.
' German text will be shown in Germany and Austria, Dutch in The
' Netherlands. In any other country the program defaults to English.

' When writing a date to the screen, CALENDER.BAS uses the correct
' delimiters (e.g. dot for Germany, slash for the UK, hyphen for
' the USA and The Netherlands)

DEFINT A - Z                          ' all variables integer, unless tagged
DIM SevenDays(1 : 7) AS SHARED STRING
DIM TwelveMonths (1 : 12) AS SHARED STRING
DIM DaysInMonth(1 : 12) AS SHARED INTEGER
DIM ScreenText(1 : 12) AS SHARED STRING

SUB FillDaysInMonth
  DaysInMonth( 1) = 31 : DaysInMonth( 2) = 28
  DaysInMonth( 3) = 31 : DaysInMonth( 4) = 30
  DaysInMonth( 5) = 31 : DaysInMonth( 6) = 30
  DaysInMonth( 7) = 31 : DaysInMonth( 8) = 31
  DaysInMonth( 9) = 30 : DaysInMonth(10) = 31
  DaysInMonth(11) = 30 : DaysInMonth(12) = 31
END SUB

SUB FillDutchArrays
  SevenDays(1) = "maandag"  : SevenDays(2) = "dinsdag"
  SevenDays(3) = "woensdag" : SevenDays(4) = "donderdag"
  SevenDays(5) = "vrijdag"  : SevenDays(6) = "zaterdag"
  SevenDays(7) = "zondag"

  TwelveMonths( 1) = "januari"   : TwelveMonths( 2) = "februari"
  TwelveMonths( 3) = "maart"     : TwelveMonths( 4) = "april"
  TwelveMonths( 5) = "mei"       : TwelveMonths( 6) = "juni"
  TwelveMonths( 7) = "juli"      : TwelveMonths( 8) = "augustus"
  TwelveMonths( 9) = "september" : TwelveMonths(10) = "oktober"
  TwelveMonths(11) = "november"  : TwelveMonths(12) = "december"

  ScreenText( 1) = "Datum: "    : ScreenText( 2) = "Tijd : "
  ScreenText( 3) = " = sluiten" : ScreenText( 4) = " = maand"
  ScreenText( 5) = " = jaar"    : ScreenText( 6) = "FEESTDAGEN"
  ScreenText( 7) = "Nieuwjaar    : "
  ScreenText( 8) = "Goede vrijdag: "
  ScreenText( 9) = "Pasen        : "
  ScreenText(10) = "Hemelvaart   : "
  ScreenText(11) = "Pinksteren   : "
  ScreenText(12) = "Kerstdagen   : "
END SUB

SUB FillEnglishArrays
  SevenDays(1) = "Monday"    : SevenDays(2) = "Tuesday"
  SevenDays(3) = "Wednesday" : SevenDays(4) = "Thursday"
  SevenDays(5) = "Friday"    : SevenDays(6) = "Saturday"
  SevenDays(7) = "Sunday"

  TwelveMonths( 1) = "January"   : TwelveMonths( 2) = "February"
  TwelveMonths( 3) = "March"     : TwelveMonths( 4) = "April"
  TwelveMonths( 5) = "May"       : TwelveMonths( 6) = "June"
  TwelveMonths( 7) = "July"      : TwelveMonths( 8) = "August"
  TwelveMonths( 9) = "September" : TwelveMonths(10) = "October"
  TwelveMonths(11) = "November"  : TwelveMonths(12) = "December"

  ScreenText( 1) = "Date : "    : ScreenText( 2) = "Time : "
  ScreenText( 3) = " = Quit"    : ScreenText( 4) = " = Month"
  ScreenText( 5) = " = Year"    : ScreenText( 6) = "CELEBRATION DAYS"
  ScreenText( 7) = "New Year     : "
  ScreenText( 8) = "Good Friday  : "
  ScreenText( 9) = "Easter       : "
  ScreenText(10) = "Ascension day: "
  ScreenText(11) = "Whit days    : "
  ScreenText(12) = "Christmas    : "
END SUB

SUB FillGermanArrays
  SevenDays(1) = "Montag"   : SevenDays(2) = "Dienstag"
  SevenDays(3) = "Mittwoch" : SevenDays(4) = "Donnerstag"
  SevenDays(5) = "Freitag"  : SevenDays(6) = "Samstag"              ' Sonnabend?
  SevenDays(7) = "Sonntag"

  TwelveMonths( 1) = "Januar"    : TwelveMonths( 2) = "Februar"
  TwelveMonths( 3) = "M„rz"      : TwelveMonths( 4) = "April"
  TwelveMonths( 5) = "Mai"       : TwelveMonths( 6) = "Juni"
  TwelveMonths( 7) = "Juli"      : TwelveMonths( 8) = "August"
  TwelveMonths( 9) = "September" : TwelveMonths(10) = "Oktober"
  TwelveMonths(11) = "November"  : TwelveMonths(12) = "Dezember"

  ScreenText( 1) = "Datum: "    : ScreenText( 2) = "Zeit : "
  ScreenText( 3) = " = Ende"    : ScreenText( 4) = " = Monat"
  ScreenText( 5) = " = Jahr"    : ScreenText( 6) = "FEIERTAGE"
  ScreenText( 7) = "Neu Jahr     : "
  ScreenText( 8) = "Karfreitag   : "
  ScreenText( 9) = "Ostern       : "
  ScreenText(10) = "Himmelfahrt  : "
  ScreenText(11) = "Pfingsten    : "
  ScreenText(12) = "Weihnachten  : "
END SUB

SUB DisplayCalendar(page, annum)
  COLOR 0, 1
  FOR row = 1 TO 8
    LOCATE row, 1
    PRINT SPACE$(55)
  NEXT

  COLOR 15
  FOR count = 1 TO 7
    header$ = header$ + LEFT$(SevenDays(count), 3) + SPACE$(3)
  NEXT
  LOCATE 1, 16 : PRINT RTRIM$(header$)

  COLOR 11                                          ' intense cyane
  year$ = RIGHT$("0000" + LTRIM$(RTRIM$(STR$(annum))), 4)
  month$ = TwelveMonths(page)
  days = DaysInMonth(page)
  IF page = 2 THEN days = days + LeapYear(year$)    ' February

  LOCATE 2, 2 : PRINT year$
  LOCATE 3, 2 : PRINT month$

  MM$ = RIGHT$("00" + LTRIM$(RTRIM$(STR$(page))), 2)
  FirstDay$ = DayOfTheWeek(MM$ + "-01-" + year$)
  start = INSTR(header$, LEFT$(FirstDay$, 3)) + 16

  row = 3
  FOR count = 1 TO days
    fore = 7
    TestDate$ = MM$ + "-" + _
                RIGHT$("00" + LTRIM$(RTRIM$(STR$(count))), 2) + _
                "-" + year$
    LOCATE row, start
    IF start     = 53 OR _
       TestDate$ = "01-01-" + year$ OR _
       TestDate$ = "12-25-" + year$ OR _
       TestDate$ = "12-26-" + year$ OR _
       TestDate$ = JulToDate(Easter(year$) -  2) OR _
       TestDate$ = JulToDate(Easter(year$) +  1) OR _
       TestDate$ = JulToDate(Easter(year$) + 39) OR _
       TestDate$ = JulToDate(Easter(year$) + 50) THEN INCR fore, 7

    IF TestDate$ = DATE$ THEN          ' to-day
      COLOR 1, fore                    ' inverse
    ELSE
      COLOR fore, 1
    END IF
    PRINT RIGHT$(SPACE$(2) + LTRIM$(RTRIM$(STR$(count))), 2)
    INCR start, 6
    IF start = 59 THEN
      start = 17 : INCR row
    END IF
  NEXT
END SUB

SUB GetCelebrationDays(year$, span&, display$)
  ' span = number of days from Easter Sunday

  MakeDate$ = JulToDate(Easter(year$) + span&)
  month$ = TwelveMonths( VAL(LEFT$(MakeDate$, 2)) )
  display$ = LTRIM$(MID$(MakeDate$, 4, 2), ANY "0")
  remember$ = month$

  IF span& = 39 OR span& = -2 THEN    ' we need only 1 day here
    display$ = display$ + CHR$(32) + month$
    EXIT SUB
  END IF

  INCR span&
  MakeDate$ = JulToDate(Easter(year$) + span&)
  month$ = TwelveMonths( VAL(LEFT$(MakeDate$, 2)) )
  IF month$ = remember$ THEN
    display$ = display$ + ", " + _
               LTRIM$(MID$(MakeDate$, 4, 2), ANY "0")
  ELSE
    display$ = display$ + CHR$(32) + remember$ + ", " + _
               LTRIM$(MID$(MakeDate$, 4, 2), ANY "0")
  END IF
  display$ = display$ + CHR$(32) + month$
END SUB

SUB DisplayFactsAndFigures
  COLOR 7, 0
  LOCATE 1, 58 : PRINT ScreenText(1);
  COLOR 15     : PRINT CountrySpecificDate(DATE$)
  COLOR 7
  LOCATE 2, 58 : PRINT ScreenText(2);
  COLOR 15     : PRINT CountrySpecificTime
  LOCATE 3, 65 : PRINT TwelveTime

  ' menu
  COLOR 12
  LOCATE 6, 58 : PRINT "Esc"
  LOCATE 7, 58 : PRINT CHR$(27, 32, 26)
  LOCATE 8, 58 : PRINT CHR$(25, 32, 24)
  COLOR 7
  LOCATE 6, 61 : PRINT ScreenText(3)
  LOCATE 7, 61 : PRINT ScreenText(4)
  LOCATE 8, 61 : PRINT ScreenText(5)

  COLOR 15
  LOCATE 09, 1 : PRINT TextualDate(DATE$)
  LOCATE 09, 1 : PRINT UCASE$(LEFT$(TextualDate(DATE$), 1))
  LOCATE 11, 1 : PRINT ScreenText(6)
  LOCATE 12, 3 : PRINT ScreenText(7)
  LOCATE 13, 3 : PRINT ScreenText(8)
  LOCATE 14, 3 : PRINT ScreenText(9)
  LOCATE 15, 3 : PRINT ScreenText(10)
  LOCATE 16, 3 : PRINT ScreenText(11)
  LOCATE 17, 3 : PRINT ScreenText(12)
  COLOR 7
  LOCATE 12, 18: PRINT "1 "; TwelveMonths(1)
  LOCATE 17, 18: PRINT "25, 26 "; TwelveMonths(12)

  LOCATE 24, 1
  PRINT "Time/Zeit/Tijd & Date/Datum Routines/Routinen ";
  PRINT "by/durch/door: ";
  COLOR 15
  LOCATE 25, 1 : PRINT "Egbert Zijlema (E.Zijlema@uni4nn.iaf.nl)";
END SUB

SUB DisplayCelebrations(annum)
  year$ = RIGHT$("0000" + LTRIM$(RTRIM$(STR$(annum))), 4)
  COLOR 15
  LOCATE 11, 1 + LEN(ScreenText(6)): PRINT " IN "; year$
  COLOR 7

  ' Karfreitag / Good Friday / Goede vrijdag
  GetCelebrationDays year$, -2, text$
  LOCATE 13, 18: PRINT SPACE$(63)            ' clear field
  LOCATE 13, 18: PRINT text$

  ' Ostern / Pasen / Easter
  GetCelebrationDays year$, 0, text$
  LOCATE 14, 18: PRINT SPACE$(63)
  LOCATE 14, 18: PRINT text$

  ' Ascension day / Himmelfahrt / Hemelvaart
  GetCelebrationDays year$, 39, text$
  LOCATE 15, 18: PRINT SPACE$(63)
  LOCATE 15, 18: PRINT text$

  ' Whitsunday + monday / Pfingsten / Pinksteren
  GetCelebrationDays year$, 49, text$
  LOCATE 16, 18: PRINT SPACE$(63)
  LOCATE 16, 18: PRINT text$
END SUB

FUNCTION GetKey AS INTEGER
  STATIC t$
  COLOR 15, 0
  DO
    IF t$ <> TIME$ THEN
      t$ = TIME$
      LOCATE 2, 65 : PRINT CountrySpecificTime
      LOCATE 3, 65 : PRINT TwelveTime
    END IF
  LOOP UNTIL INSTAT
  FUNCTION = CVI(INKEY$ + CHR$(0))
END FUNCTION

FUNCTION Easter(year$) AS LONG
  year = VAL(year$)
  temp1 = ((8 * (year \ 100)) + 13) \ 25 : DECR temp1, 2
  leap  = (year \ 100) - (year \ 400) - 2
  temp2 = (15 + leap - temp1) MOD 30
  temp3 = (6 + leap) MOD 7
  day   = ( temp2 + 19 * (year MOD 19) ) MOD 30
  IF (day = 29) OR (day = 28 AND year MOD 19 >= 11) THEN DECR day
  factor = ( 2 * (year MOD 4) + 4 * (year MOD 7) + 6 * day + temp3 ) MOD 7
  INCR day, factor + 22
  IF day <= 31 THEN
    FUNCTION = Julian("03-" + _
                      RIGHT$("00" + LTRIM$(RTRIM$(STR$(day))), 2) + _
                      "-" + year$)
  ELSE
    DECR day, 31
    FUNCTION = Julian("04-" + _
                      RIGHT$("00" + LTRIM$(RTRIM$(STR$(day))), 2) + _
                      "-" + year$)
  END IF
END FUNCTION

SUB GetCountryInfo(format, buffer$)
  ' results depend on correct COUNTRY settings in CONFIG.SYS

  buffer$ = SPACE$(64)                ' information buffer
  REG 8, STRSEG(buffer$)              ' DS = segment of buffer
  REG 4, STRPTR(buffer$)              ' DX = offset of buffer
  REG 1, &H3800                       ' AX = service
  CALL INTERRUPT &H21
  ' after the call buffer$ = filled
  format = ASC(buffer$)               ' date format (1 out of 3) = 1st byte
END SUB

FUNCTION CountrySpecificDate(InDate$) AS STRING
  ' InDate$ as MM-DD-[-]YYYY (= default format)

  IF InDate$ = "" THEN InDate$ = DATE$
  MM$ = MID$(InDate$, 1, 2)
  DD$ = MID$(InDate$, 4, 2)
  YY$ = BeforeChrist(InDate$)      ' year maybe negative

  GetCountryInfo form, buffer$
  delim$ = MID$(buffer$, 12, 1)    ' date delimiter = 12th byte
  SELECT CASE form
    CASE 0
      FUNCTION = LEFT$(InDate$, 6) + YY$            ' USA (Basic's default)
    CASE 1
      FUNCTION = DD$ + delim$ + MM$ + delim$ + YY$  ' EUR
    CASE 2
      FUNCTION = LEFT$(YY$, 4) + delim$ + MM$ + _
                 delim$ + DD$  + MID$(YY$, 5)       ' JAP
  END SELECT
END FUNCTION

FUNCTION TextualDate(InDate$) AS STRING
  ' InDate$ as MM-DD-[-]YYYY (= default format)
  ' output (sample): Saturday, 4 January 1997

  month = VAL(MID$(InDate$, 1, 2))
  MM$   = TwelveMonths(month)
  DD$   = MID$(InDate$, 4, 2)
          IF LEFT$(DD$, 1) = "0" THEN DD$ = MID$(DD$, 2)
  YY$   = LTRIM$(BeforeChrist(InDate$), ANY "0")

  FUNCTION = DayOfTheWeek(InDate$) + ", " + DD$ + CHR$(32) + _
             MM$ + CHR$(32) + YY$
END FUNCTION

FUNCTION CountrySpecificTime AS STRING
  ' Are there countries anyway, NOT using the default delimiter
  ' in TIME$? Not sure! Did'nt find any, but you never can tell.
  ' Therefore this harmless but perhaps also useless routine.

  GetCountryInfo dummy, buffer$
  delim$ = MID$(buffer$, 14, 1)    ' time delimiter = 14th byte

  FUNCTION = LEFT$(TIME$, 2) + delim$ + MID$(TIME$, 4, 2) + _
             delim$ + MID$(TIME$, 7)
END FUNCTION

FUNCTION TwelveTime AS STRING
  temp$ = CountrySpecificTime
  hour = VAL(LEFT$(temp$, 2))
  SELECT CASE hour
    CASE > 11
      IF hour > 12 THEN DECR hour, 12
      extension$ = " PM"
    CASE ELSE
      IF hour = 0 THEN hour = 12
      extension$ = " AM"
  END SELECT
  FUNCTION = RIGHT$(SPACE$(2) + LTRIM$(RTRIM$(STR$(hour))), 2) + _
             MID$(temp$, 3) + extension$
END FUNCTION

FUNCTION DayOfTheWeek (InDate$) AS STRING
    ' returns the name for each day of the week

  month = VAL( LEFT$(InDate$, 2) )
  day   = VAL( MID$(InDate$, 4, 2) )
  year  = VAL( MID$(InDate$, 7) )

  DECR month, 2
  IF month < 1 OR month > 10 THEN
    INCR month, 12 : DECR year
  END IF
  century = year \ 100
  year = year MOD 100
  temp = INT(2.6 * month - .19) + day + year + (year \ 4)
  result = (temp + (century \ 4) - (century * 2)) MOD 7
  IF result < 1 THEN INCR result, 7
  FUNCTION = SevenDays(result)
END FUNCTION

FUNCTION BeforeChrist(InDate$) AS STRING
  ' adjust negative year to eliminate non-existing year zero

  year = VAL(MID$(InDate$, 7))
  IF year < 1 THEN                    ' v.C.
    DECR year
    extension$ = " (v.C.)"
  END IF

  FUNCTION = RIGHT$("0000" + LTRIM$(RTRIM$(STR$(ABS(year)))), 4) + _
             extension$
END FUNCTION

FUNCTION Julian (InDate$) AS LONG
  ' Converts InDate$ (format: "MM-DD-[-]YYYY") into its Julian number.
  ' Valid dates range from "11/25/-4713" (Julian& = 1) through
  ' "12/31/9999" (= highest possible 4-digit year).
  ' Remember: computational years -4713 through 0 actually represent
  '           4714 - 1 b.C., because the year zero did not exist.

  IF LEN(InDate$) < 10 THEN EXIT FUNCTION    ' invalid format
  Y& = VAL( MID$(InDate$, 7) )               ' year
  M& = VAL( LEFT$(InDate$, 2) )              ' month
  D& = VAL( MID$(InDate$, 4, 2) )            ' day
  temp& = (M& - 14) \ 12
  JulPart& = D& - 32075 + (1461 * (Y& + 4800 + temp&) \ 4)
  JulPart& = JulPart& + (367 * (M& - 2 - temp& * 12) \ 12)

  FUNCTION = JulPart& - (3 * ((Y& + 4900 + temp&) \ 100) \ 4)
END FUNCTION

FUNCTION JulToDate (Jul&) AS STRING
  ' converts a Julian number into a computational date ("MM-DD-[-]YYYY")

  IF (Jul& < 1) OR (Jul& > 5373484) THEN     ' invalid value
    EXIT FUNCTION
  END IF

  INCR Jul&, 68569
  help& = 4 * Jul& \ 146097
  DECR Jul&, (146097 * help& + 3) \ 4
  TempYear& = 4000 * (Jul& + 1) \ 1461001
  DECR Jul&, 1461 * TempYear& \ 4
  INCR Jul&, 31
  TempMonth& = 80 * Jul& \ 2447

  day& = Jul& - (2447 * TempMonth& \ 80)
  day$ = RIGHT$("00" + LTRIM$(RTRIM$(STR$(day&))), 2)

  month& = TempMonth& + 2 - (12 * (TempMonth& \ 11))
  month$ = RIGHT$("00" + LTRIM$(RTRIM$(STR$(month&))), 2)

  year& = 100 * (help& - 49) + TempYear& + (TempMonth& \ 11)
  year$ = RIGHT$("0000" + LTRIM$(RTRIM$(STR$(ABS(year&)))), 4)
  IF year& < 0 THEN year$ = "-" + year$

  FUNCTION = month$ + "-" + day$ + "-" + year$
END FUNCTION

FUNCTION LeapYear(year$)
  InDate$ = "02-28-" + RIGHT$("0000" + year$, 4)       ' convert Feb 28
  OutDate$ = JulToDate(Julian(InDate$) + 1)            ' next date

  IF LEFT$(OutDate$, 5) = "02-29" THEN
    FUNCTION = 1                                       ' 1 extra day for Feb
  ELSE
    FUNCTION = 0
  END IF
END FUNCTION

' demo
CLS
  FillDaysInMonth
  GetCountryInfo dummy, buff$
  country$ = EXTRACT$(MID$(buff$, 3, 2), ANY CHR$(0))
  SELECT CASE LTRIM$(RTRIM$(country$))
    CASE "Ÿ"  : FillDutchArrays                        ' Netherlands
    CASE "DM" : FillGermanArrays                       ' Germany
    CASE "S"
      IF MID$(buff$, 12, 1) = "." THEN                 ' Austria
        FillGermanArrays
      END IF
    CASE ELSE : FillEnglishArrays
  END SELECT
  page = VAL(LEFT$(DATE$, 2))                          ' actual month
  annum = VAL(MID$(DATE$, 7))                          ' actual year
  DisplayCalendar page, annum
  DisplayFactsAndFigures
  DisplayCelebrations annum

  ' menu
  DO
    KeyIn = GetKey
    SELECT CASE KeyIn
      CASE 77 * 256                 ' right arrow
        INCR page
        IF page > 12 THEN
          page = 1
          INCR annum
          DisplayCelebrations annum
        END IF
        DisplayCalendar page, annum
      CASE 75 * 256                 ' left arrow
        DECR page
        IF page < 1 THEN
          page = 12
          DECR annum
          DisplayCelebrations annum
        END IF
        DisplayCalendar page, annum
      CASE 72 * 256                 ' up arrow
        INCR annum
        DisplayCelebrations annum
        DisplayCalendar page, annum
      CASE 80 * 256                 ' down arrow
        DECR annum
        DisplayCelebrations annum
        DisplayCalendar page, annum
    END SELECT
  LOOP UNTIL KeyIn = 27
  COLOR 7, 0
  CLS
END