'===========================================================================
' Subject: MULTI-LANGUAGE CALENDAR ROUTINE    Date: 01-13-97 (13:05)       
'  Author: Egbert Zijlema                     Code: PB                     
'  Origin: e.zylema@castel.nl               Packet: DATETIME.ABC
'===========================================================================
$LIB ALL OFF
$ERROR ALL OFF
$OPTIMIZE SIZE
$FLOAT NPX                             ' for machines with math processor
$CPU 80386                             ' 386 and higher

' $COMPILE EXE "FEESTDGN.EXE"          ' dutch   }
' $COMPILE EXE "FEIERTAG.EXE"          ' german  } un-REM filename of choice
' $COMPILE EXE                         ' english }


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

' CELEBRAT.BAS displays the dates of the celebration days for a given year.
' Additionally it performs a browsable monthly calendar.

' 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, it uses the correct
' delimiters (e.g. dot for Germany, slash for the UK, hyphen for
' the USA and The Netherlands)

' Note: ASCII characters > 127 are written as: CHR$(<value>). This has
'       no special reason, except to avoid that Window's Notepad will
'       change them when copying the code to my Internet mailer (e.g.:
'       the German name for March, the Dutch florin sign)

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 : 15) 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 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                 ' fill buffer$
  format = ASC(buffer$)               ' date format (1 out of 3) = 1st byte
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) = " = afsluiten"    : 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   : "
  ScreenText(13) = " v.C."           : ScreenText(14) = " = eeuw"
  ScreenText(15) = "Tijd- en datumroutines door: "
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    : "
  ScreenText(13) = " b.C."           : ScreenText(14) = " = Century"
  ScreenText(15) = "Time & date routines by: "
END SUB

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

  TwelveMonths( 1) = "Januar"    : TwelveMonths( 2) = "Februar"
  TwelveMonths( 3) = "M" + CHR$(132) + "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  : "
  ScreenText(13) = " v.C."           : ScreenText(14) = " = Jahr100"
  ScreenText(15) = "Zeit und Datum Routinen durch: "
END SUB

SUB DisplayCalendar(page, annum)
  FirstDay$ = DayOfTheWeek(annum, page, 1)     ' 1st day of the month

  Y = VAL(MID$(DATE$, 7))                      ' }
  M = VAL(LEFT$(DATE$, 2))                     ' } actual date
  D = VAL(MID$(DATE$, 4, 2))                   ' } we need this to test
  ToDay& = Julian(Y, M, D)                     ' } for inverse displaying

  days = DaysInMonth(page)                     ' number of days
  IF page = 2 THEN                             ' February
    days = days + LeapYear(annum)              ' 28 + 1 ?
  END IF

  COLOR 0, 1                                   ' calendar's background blue
  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
  LOCATE 2, 2 : PRINT YearToDisplay(annum)
  LOCATE 3, 2 : PRINT TwelveMonths(page)       ' name of the month

  ' display calendar:
  col = INSTR(header$, LEFT$(FirstDay$, 3)) + 16
  row = 3
  FOR count = 1 TO days
    fore = 7
    TestDate& = Julian(annum, page, count)
    IF col      = 53 OR _
      count = 1 AND page = 1 OR _              ' NewYear
      count = 25 AND page = 12 OR _            ' Christmas Day
      count = 26 AND page = 12 OR _            ' Boxing Day
      TestDate& = GoodFriday(annum) OR _
      TestDate& = EasterMonday(annum) OR _
      TestDate& = AscensionDay(annum) OR _
      TestDate& = WhitMonday(annum) THEN INCR fore, 7      ' yellow

    IF TestDate& = ToDay& THEN
      IF fore = 14 THEN COLOR 14, 7 ELSE COLOR 1, fore     ' inverse
    ELSE
      COLOR fore, 1
    END IF
    LOCATE row, col
    IF annum = -4713 AND page = 11 AND count < 25 THEN
      PRINT SPACE$(2)                          ' skip Julians < 1
    ELSE
      PRINT RIGHT$(SPACE$(2) + LTRIM$(RTRIM$(STR$(count))), 2)
    END IF
    INCR col, 6
    IF col = 59 THEN
      col = 17 : INCR row
    END IF
  NEXT
END SUB

SUB DisplayCelebrations(year)
  COLOR 7, 0
  FOR row = 13 TO 16
    LOCATE row, 18 : PRINT SPACE$(63)         ' clear fields
  NEXT
  temp$ = JulToDate(GoodFriday(year))
  LOCATE 13, 18
  PRINT LTRIM$(MID$(temp$, 4, 2), ANY "0"); CHR$(32);
  PRINT TwelveMonths(VAL(LEFT$(temp$, 2)))
  TwoDays EasterSunday(year), EasterMonday(year), temp$
  LOCATE 14, 18 : PRINT temp$
  temp$ = JulToDate(AscensionDay(year))
  LOCATE 15, 18
  PRINT LTRIM$(MID$(temp$, 4, 2), ANY "0"); CHR$(32);
  PRINT TwelveMonths(VAL(LEFT$(temp$, 2)))
  TwoDays WhitSunday(year), WhitMonday(year), temp$
  LOCATE 16, 18 : PRINT temp$
END SUB

SUB TwoDays(first&, second&, result$)
  temp1$ = JulToDate(first&)
  temp2$ = JulToDate(second&)
  month1$ = TwelveMonths(VAL(LEFT$(temp1$, 2)))
  month2$ = TwelveMonths(VAL(LEFT$(temp2$, 2)))
  result$ = LTRIM$(MID$(temp1$, 4, 2), ANY "0")
  IF month1$ = month2$ THEN
    result$ = result$ + ", " + LTRIM$(MID$(temp2$, 4, 2), ANY "0") + _
              CHR$(32) + month2$
  ELSE
    result$ = result$ + CHR$(32) + month1$ + ", " + _
              LTRIM$(MID$(temp2$, 4, 2), ANY "0") + CHR$(32) + month2$
  END IF
END SUB

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

SUB InitialScreen
  COLOR 12, 0
  LOCATE 5, 58 : PRINT "Esc"
  LOCATE 6, 58 : PRINT CHR$(27, 32, 26)
  LOCATE 7, 58 : PRINT CHR$(25, 32, 24)
  LOCATE 8, 58 : PRINT "PgUp/Dn"
  LOCATE 9, 58 : PRINT "Home"

  COLOR 15
  LOCATE 1, 65 : PRINT CountrySpecificDate(DATE$)
  LOCATE  9, 1 : PRINT TextualDate(DATE$)
  LOCATE  9, 1 : PRINT UCASE$(LEFT$(TextualDate(DATE$), 1))  ' dutch
  LOCATE 11, 1 + LEN(ScreenText(6))
                 PRINT " IN "; YearToDisplay(VAL(MID$(DATE$, 7)))
  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)
  LOCATE 25, 1 + LEN(ScreenText(15)) : PRINT "Egbert Zijlema";

  COLOR 7
  LOCATE 1, 58 : PRINT ScreenText(1)
  LOCATE 2, 58 : PRINT ScreenText(2)
  LOCATE 5, 65 : PRINT ScreenText(3)
  LOCATE 6, 65 : PRINT ScreenText(4)
  LOCATE 7, 65 : PRINT ScreenText(5)
  LOCATE 8, 65 : PRINT ScreenText(14)
  LOCATE 12, 18: PRINT "1 "; TwelveMonths(1)
  LOCATE 17, 18: PRINT "25, 26 "; TwelveMonths(12)
  LOCATE 25, 1 : PRINT ScreenText(15);
END SUB

SUB Menu
  page  = VAL(LEFT$(DATE$, 2))
  annum = VAL(MID$(DATE$, 7))
  DisplayCalendar page, annum
  DisplayCelebrations annum

  DO
    KeyIn = GetKey
    calendar = 0 : celebrat = 0
    SELECT CASE KeyIn
      CASE 77 * 256                                     ' right arrow
        IF annum = 9999 AND page = 12 THEN EXIT SELECT  ' highest 4 digityr
        INCR page
        IF page > 12 THEN
          page = 1
          INCR annum
          celebrat = -1
        END IF
        calendar = -1
      CASE 75 * 256                                     ' left arrow
        IF annum = -4713 AND page < 12 THEN EXIT SELECT ' Julian < 1
        DECR page
        IF page < 1 THEN
          page = 12
          DECR annum
          celebrat = -1
        END IF
        calendar = -1
      CASE 81 * 256                                     ' PgDn
        IF annum > 9899 THEN EXIT SELECT
        INCR annum, 100
        calendar = -1
        celebrat = -1
      CASE 71 * 256                                     ' Home
        yr  = VAL(MID$(DATE$, 7))
        mth = VAL(LEFT$(DATE$, 2))
        IF annum = yr AND page = mth THEN EXIT SELECT
        IF annum <> yr THEN
          annum = yr
          celebrat = -1
        END IF
        page = mth
        calendar = -1
      CASE 72 * 256                                     ' up arrow
        IF annum = 9999 THEN EXIT SELECT
        INCR annum
        calendar = -1
        celebrat = -1
      CASE 73 * 256                                     ' PgUp
        IF annum < -4612 THEN EXIT SELECT
        DECR annum, 100
        calendar = -1
        celebrat = -1
      CASE 80 * 256                                     ' down arrow
        IF annum = -4712 THEN EXIT SELECT
        DECR annum
        calendar = -1
        celebrat = -1
    END SELECT
    IF celebrat THEN DisplayCelebrations annum
    IF calendar THEN DisplayCalendar page, annum
  LOOP UNTIL KeyIn = 27
  COLOR 7, 0
  CLS
  SYSTEM
END SUB

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

  year = VAL(MID$(InDate$, 7))
  YY$  = YearToDisplay(year)
  GetCountryInfo form, buffer$
  delimiter$ = MID$(buffer$, 12, 1)                  ' 12th byte
  REPLACE "-" WITH delimiter$ IN InDate$

  SELECT CASE form
    CASE 0 : FUNCTION = LEFT$(InDate$, 6) + YY$                  ' USA
    CASE 1
      FUNCTION = MID$(InDate$, 4, 3) + LEFT$(InDate$, 3) + YY$   ' EUR
    CASE 2
      FUNCTION = LEFT$(YY$, 4) + delimiter$ + LEFT$(InDate$, 3) + _
                 MID$(InDate$, 4, 2) + 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

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

  FUNCTION = DayOfTheWeek(year, month, day) + ", " + _
             LTRIM$(STR$(day)) + CHR$(32) + _
             TwelveMonths(month) + CHR$(32) + _
             LTRIM$(YearToDisplay(year), ANY "0")         ' no zeros here
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.

  t$ = TIME$
  GetCountryInfo dummy, buffer$
  REPLACE ":" WITH MID$(buffer$, 14, 1) IN t$  ' time delimiter = 14th byte

  FUNCTION = t$
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 YearToDisplay(year) AS STRING
  CountYear = year
  IF CountYear < 1 THEN
    DECR CountYear
    extension$ = ScreenText(13)
  END IF
  FUNCTION = RIGHT$("0000" + LTRIM$(RTRIM$(STR$(ABS(CountYear)))), 4) + _
             extension$
END FUNCTION

FUNCTION EasterSunday(year) AS LONG
  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
  days  = ( temp2 + 19 * (year MOD 19) ) MOD 30
  IF (days = 29) OR (days = 28 AND year MOD 19 >= 11) THEN DECR days
  factor = ( 2 * (year MOD 4) + 4 * (year MOD 7) + 6 * days + temp3 ) MOD 7
  INCR days, factor + 21
  FUNCTION = Julian(year, 3, 1) + days       ' 1 March + nbr of days
END FUNCTION

FUNCTION EasterMonday(year) AS LONG
  FUNCTION = EasterSunday(year) + 1
END FUNCTION

FUNCTION GoodFriday(year) AS LONG
  FUNCTION = EasterSunday(year) - 2
END FUNCTION

FUNCTION AscensionDay(year) AS LONG
  FUNCTION = EasterSunday(year) + 39
END FUNCTION

FUNCTION WhitSunday(year) AS LONG
  FUNCTION = EasterSunday(year) + 49
END FUNCTION

FUNCTION WhitMonday(year) AS LONG
  FUNCTION = EasterSunday(year) + 50
END FUNCTION

FUNCTION Julian(year, month, day) AS LONG
  temp& = (month - 14) \ 12
  JulPart& = day - 32075 + (1461 * (year + 4800 + temp&) \ 4)
  JulPart& = JulPart& + (367 * (month - 2 - temp& * 12) \ 12)
  FUNCTION = JulPart& - (3 * ((year + 4900 + temp&) \ 100) \ 4)
END FUNCTION

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

  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)
  OutDate$ = JulToDate(Julian(year, 2, 28) + 1)        ' 28 Feb + 1 day
  IF LEFT$(OutDate$, 5) = "02-29" THEN
    FUNCTION = 1                                       ' 1 extra day for Feb
  ELSE
    FUNCTION = 0
  END IF
END FUNCTION

FUNCTION DayOfTheWeek(BYVAL year, BYVAL month, BYVAL day) AS STRING
  ' returns the name for each day of the week

  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

CLS
  FillDaysInMonth
  GetCountryInfo dummy, buff$
  country$ = EXTRACT$(MID$(buff$, 3, 2), ANY CHR$(0))
  SELECT CASE LTRIM$(RTRIM$(country$))
    CASE CHR$(159) : FillDutchArrays                   ' Netherlands
    CASE "DM" : FillGermanArrays                       ' Germany
    CASE "S"
      IF MID$(buff$, 12, 1) = "." THEN                 ' Austria
        FillGermanArrays
      END IF
    CASE ELSE : FillEnglishArrays                      ' other countries
  END SELECT
  InitialScreen
  Menu
END