' KALENDER.BAS - ein mehrzweckiger Kalender
' Autor        : Egbert Zijlema (E.Zijlema@uni4nn.iaf.nl)
' Datum        : 7 Januar 1997 (Julian 2450456)
' Status       : Public Domain
' Sprache      : Power Basic 3.2 f�r DOS

' KALENDER.BAS ist eine Verbesserung einer fr�heren Version namens
' TIMEDATE.BAS. Sie enthaelt 3 neue FUNCTIONEN:
'   1. CountrySpecificDate
'   2. CountrySpecificTime
'   3. Easter
' Die Nummern 1/2 zeigen Datum/Zeit mit die richtigen Trennungs-
' zeichen (z.B. Punkt im Datum); die dritte erhaelt alle Feiertage
' die mit Ostern zusammenhangen (Himmelfahrt, Pfingsten, Karfreitag).

DEFINT A - Z                          ' integer vars unless tagged

daydata:
  DATA Montag, Dienstag, Mittwoch, Donnerstag, Freitag, Samstag, Sonntag
monthdata:
  DATA Januar, 31, Februar, 28, M„rz, 31, April, 30, Mai, 31
  DATA Juni, 30, Juli, 31, August, 31, September, 30
  DATA Oktober, 31, November, 30, Dezember, 31

SUB DisplayCalendar(page, annum)

  COLOR 0, 1               ' blauer Hintergrund
  FOR row = 1 TO 8
    LOCATE row, 1
    PRINT SPACE$(55)
  NEXT

  COLOR 15                 ' weisser Vordergrund
  RESTORE daydata
  FOR count = 1 TO 7
    READ day$
    header$ = header$ + LEFT$(day$, 3) + SPACE$(3)
  NEXT
  LOCATE 1, 16 : PRINT RTRIM$(header$)

  COLOR 11                 ' intense cyane
  year$ = RIGHT$("0000" + LTRIM$(RTRIM$(STR$(annum))), 4)
  RESTORE monthdata
  FOR count = 1 TO page
    READ month$, days
  NEXT
  IF page = 2 THEN days = days + LeapYear(year$)    ' Febr

  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, 8

    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&)
  RESTORE monthdata
  FOR count = 1 TO VAL(LEFT$(MakeDate$, 2))
    READ month$, dummy
  NEXT
  display$ = month$ + CHR$(32) + LTRIM$(MID$(MakeDate$, 4, 2), ANY "0")

  IF span& = 39 OR span& = -2 THEN    ' wir brauchen hier nur 1 Tag
    EXIT SUB
  END IF

  INCR span&
  display$ = display$ + ", "
  MakeDate$ = JulToDate(Easter(year$) + span&)
  RESTORE monthdata
  FOR count = 1 TO VAL(LEFT$(MakeDate$, 2))
    READ month$, dummy
  NEXT
  IF month$ <> LEFT$(display$, LEN(month$)) THEN
    display$ = display$ + month$ + CHR$(32)
  END IF
  display$ = display$ + LTRIM$(MID$(MakeDate$, 4, 2), ANY "0")
END SUB

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

  ' menu
  COLOR 14
  LOCATE 5, 58 : PRINT "Esc"
  LOCATE 6, 58 : PRINT CHR$(27, 32, 26)
  LOCATE 7, 58 : PRINT CHR$(24, 32, 25)
  COLOR 7
  LOCATE 5, 61 : PRINT " = Ende"
  LOCATE 6, 61 : PRINT " = Monat"
  LOCATE 7, 61 : PRINT " = Jahr"

  LOCATE 10, 1 : PRINT "Heute ist                    : ";
                 PRINT TextualDate(DATE$)
  LOCATE 11, 1 : PRINT "Julianische Nummer           : ";
                 PRINT LTRIM$(RTRIM$(STR$(Julian(DATE$))))
  LOCATE 12, 1 : PRINT "Julianische Nummern gehen von: ";
                 PRINT TextualDate(JulToDate(1))
  LOCATE 13, 27: PRINT "bis: "; TextualDate("12-31-9999")

  COLOR 15
  LOCATE 15, 1 : PRINT "FEIERTAGE IN "
  LOCATE 16, 3 : PRINT "NeuJahr    : "
  LOCATE 17, 3 : PRINT "Karfreitag : "
  LOCATE 18, 3 : PRINT "Ostern     : "
  LOCATE 19, 3 : PRINT "Himmelfahrt: "
  LOCATE 20, 3 : PRINT "Pfingsten  : "
  LOCATE 21, 3 : PRINT "Wheinachten: "
  COLOR 7
  LOCATE 16, 16: PRINT "Januar 1"
  LOCATE 21, 16: PRINT "Dezember 25, 26"

  LOCATE 24, 1 : PRINT "Zeit- & Datumsmanipulationen - Die ";
                 PRINT "™ffentlichkeit verschenkt"
  LOCATE 25, 1 : PRINT "worden von ";
                 PRINT "Egbert Zijlema (E.Zijlema@uni4nn.iaf.nl)";
END SUB

SUB DisplayCelebrations(annum)
  year$ = RIGHT$("0000" + LTRIM$(RTRIM$(STR$(annum))), 4)
  COLOR 15
  LOCATE 15, 14: PRINT year$
  COLOR 7

  ' Karfreitag
  GetCelebrationDays year$, -2, kar$
  LOCATE 17, 16: PRINT SPACE$(65)
  LOCATE 17, 16: PRINT kar$

  ' Ostern
  GetCelebrationDays year$, 0, east$
  LOCATE 18, 16: PRINT SPACE$(65)            ' clear field
  LOCATE 18, 16: PRINT east$

  ' Himmelfahrt
  GetCelebrationDays year$, 39, thursday$
  LOCATE 19, 16: PRINT SPACE$(65)
  LOCATE 19, 16: PRINT thursday$

  ' Pfingsten
  GetCelebrationDays year$, 49, whit$
  LOCATE 20, 16: PRINT SPACE$(65)
  LOCATE 20, 16: PRINT whit$
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))
  DD$   = MID$(InDate$, 4, 2)
          IF LEFT$(DD$, 1) = "0" THEN DD$ = MID$(DD$, 2)
  YY$   = LTRIM$(BeforeChrist(InDate$), ANY "0")

  RESTORE monthdata
  FOR count = 1 TO month
    READ month$, dummy
  NEXT

  FUNCTION = DayOfTheWeek(InDate$) + ", " + DD$ + CHR$(32) + _
             month$ + 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 = 0 THEN result = 7                       ' Sunday = 7

  RESTORE daydata
  FOR count = 1 TO result
    READ day$
  NEXT
  FUNCTION = day$
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
  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 80 * 256                 ' down arrow
        INCR annum
        DisplayCelebrations annum
        DisplayCalendar page, annum
      CASE 72 * 256                 ' up arrow
        DECR annum
        DisplayCelebrations annum
        DisplayCalendar page, annum
    END SELECT
  LOOP UNTIL KeyIn = 27
  COLOR 7, 0
  CLS
END