'===========================================================================
' Subject: SEVERAL DATE & TIME ROUTINES       Date: 06-14-96 (13:33)       
'  Author: Egbert Zijlema                     Code: PB                     
'  Origin: E.Zijlema@uni4nn.iaf.nl          Packet: DATETIME.ABC
'===========================================================================
$LIB ALL OFF
$ERROR ALL OFF
$OPTIMIZE SIZE
$COMPILE EXE      ' compile it to let the daylight saving part run

' TIMEDATE.BAS    - Routines for date and time processing

' Author          : Egbert Zijlema <E.Zijlema@uni4nn.iaf.nl>
' Date            : June 14, 1996
' Copyright status: Public Domain

' TIMEDATE.BAS contains several routines to manipulate date and time
' It includes a test for Daylight Saving:
' On first use it stores the actual half year ("SUMMER" or "WINTER") at
' the end of the file. Therefore the DLS-part of this demo does not work
' in the IDE, in order to make sure PB.EXE itself will not become affected.

' If you include TIMEDATE.EXE in your AUTOEXEC.BAT file, it will check
' for Daylight Saving on every startup. In that case leave the demo's
' out and rewrite the main module before compiling, as follows:

'                          CLS
'                          DayLightSaving
'                          END

' Credit: The routine to detect the file's own path (FUNCTION MySelf)
'         comes from Thomas Gohel, the maintainer of the PBSound WebSite
'         in Germany. Thank you, Thomas!

DEFINT A - Z

daydata:
  DATA Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday
monthdata:
  DATA January, February, March, April, May, June, July, August
  DATA September, October, November, December
daysinmonthdata:
  DATA 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31

' Trim all spaces from both ends of a string
FUNCTION TRIM(BYVAL text AS STRING) AS STRING
  FUNCTION = LTRIM$(RTRIM$(text))
END FUNCTION

' Right align a string
FUNCTION rgtALIGN(BYVAL text AS STRING, BYVAL length) AS STRING
  FUNCTION = RIGHT$(SPACE$(length) + text, length)
END FUNCTION

FUNCTION MySelf AS STRING

  ' from Thomas Gohel, Germany
  ' detects the full pathname of the running executable

  ! mov ax, &H6200
  ! int &H21
  ! mov es, bx
  ! mov ax, WORD PTR es:[&H2C]
  ! mov pbvDefSeg, ax           ; undocumented in PowerBASIC 3.0

  count = 0
  DO
    INCR count
  LOOP UNTIL PEEK$(count, 4) = CHR$(0, 0, 1, 0)

  DO WHILE PEEK(count + 4) <> 0
    temp$ = temp$ + CHR$(PEEK(count + 4))
    INCR count
  LOOP

  DEF SEG

  FUNCTION = temp$
END FUNCTION

FUNCTION Julian& (InDate$)

  ' converts a date into it's Julian number
  IF LEN(InDate$) < 10 THEN EXIT FUNCTION    ' format "mm-dd-[-]yyyy"
  Y& = VAL( MID$(InDate$, 7) )               ' year (maybe negative = b.C.)
  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

SUB JulToDate (JN&, ResultDate$)

  ' converts the Julian number of a date into it's
  ' date form ("mm-dd-[-]yyyy")
  JulNumber& = JN& + 68569
  help& = 4 * JulNumber& \ 146097
  JulNumber& = JulNumber& - (146097 * help& + 3) \ 4
  TempYear& = 4000 * (JulNumber& + 1) \ 1461001
  JulNumber& = JulNumber& - (1461 * TempYear& \ 4) + 31
  TempMonth& = 80 * JulNumber& \ 2447
  day = CINT(JulNumber& - (2447 * TempMonth& \ 80))
  month = CINT(TempMonth& + 2 - (12 * (TempMonth& \ 11)))
  year = CINT(100 * (help& - 49) + TempYear& + (TempMonth& \ 11))
  month$ = rgtALIGN(STR$(month), 2) + "-"
  day$ = rgtALIGN(STR$(day), 2) + "-"
  year$ = rgtALIGN(STR$(ABS(year)), 4)               ' maybe negative
  REPLACE CHR$(32) WITH "0" IN year$
  IF year < 0 THEN year$ = "-" + year$
  ResultDate$  = month$ + day$ + year$
  REPLACE CHR$(32) WITH "0" IN ResultDate$
END SUB

FUNCTION LeapYear (TestYear$)

  ' tests if a given year is a leap year
  JulNumber& = Julian&("02-28-" + TestYear$)
  INCR JulNumber&                                ' the next day we need!
  JulToDate JulNumber&, Result$                  ' convert to stringformat

  IF LEFT$(Result$, 5) = "02-29" THEN
    FUNCTION = 1
  ELSE
    FUNCTION = 0
  END IF
END FUNCTION

FUNCTION DayWeek (InDate$)
    ' returns a number for each day of the week
    ' range 1...7 = Monday up to Sunday

  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

  FUNCTION = result
END FUNCTION

SUB LastSunday(month$, sunday&)
  day = 32
  DO
    DECR day
    InDate$ = month$ + TRIM(STR$(day)) + MID$(DATE$, 6)
    number = DayWeek(InDate$)
  LOOP UNTIL number = 7
  sunday& = Julian&(InDate$)
END SUB

FUNCTION DayLightBegin&
  ' returns last Sunday of March as Julian

  LastSunday "03-", temp&
  FUNCTION = temp&
END FUNCTION

FUNCTION DayLightEnd&
  ' returns last Sunday of October as Julian

  LastSunday "10-", temp&
  FUNCTION = temp&
END FUNCTION

SUB DayLightSaving
  TestDate& = Julian&(DATE$)
  SELECT CASE TestDate&
    CASE < DayLightBegin&, > DayLightEnd&
      clock = -1
    CASE DayLightBegin&
      IF VAL( LEFT$(TIME$, 2) ) < 2 THEN clock = -1 ELSE clock = 1
    CASE DayLightEnd&
      IF VAL( LEFT$(TIME$, 2) ) > 2 THEN clock = -1 ELSE clock = 1
    CASE ELSE
      clock = 1
  END SELECT
  IF clock = 1 THEN dlsFlag$ = "SUMMER" ELSE dlsFlag$ = "WINTER"
  handle = FREEFILE
  OPEN "B", #handle, MySelf
  SEEK #handle, LOF(1) - 6
  GET$ #handle, 6, setting$

  ' if newly installed:
  IF setting$ <> "SUMMER" AND setting$ <> "WINTER" THEN
    CLOSE #handle
    InstallActualSetting dlsFlag$
    EXIT SUB
  END IF

  IF setting$ <> dlsFlag$ THEN
    SEEK #handle, LOF(handle) - 6
    PUT$ #handle, dlsFlag$
    AdjustTime clock
  END IF
  CLOSE #handle
END SUB

SUB InstallActualSetting(flag$)
  handle = FREEFILE
  OPEN "B", #handle, MySelf
  SEEK #handle, LOF(handle)
  PUT$ #handle, flag$
  CLOSE #handle
END SUB

SUB AdjustTime(clock)

  ' change the clock by 1 hour + or -
  ' adjust date, if necessary
  hour = VAL( LEFT$(TIME$, 2) )
  INCR hour, clock                          ' clock = -1 or +1
  IF hour > 23 THEN
    DECR hour, 24
    JulToDate Julian&(DATE$) + 1, ResultDate$
    DATE$ = ResultDate$
  ELSEIF hour < 0 THEN
    INCR hour, 24
    JulToDate Julian&(DATE$) - 1, ResultDate$
    DATE$ = ResultDate$
  END IF
  hour$ = TRIM(STR$(hour))
  IF hour < 10 THEN hour$  = "0" + hour$
  TIME$ = hour$ + MID$(TIME$, 3)
END SUB

FUNCTION MonthName(InDate$) AS STRING
  RESTORE monthdata
  number = VAL( LEFT$(InDate$, 2) )
  FOR count = 1 TO number
    READ temp$
  NEXT
  FUNCTION = temp$ + CHR$(32)
END FUNCTION

FUNCTION DayName(InDate$) AS STRING
  RESTORE daydata
  number = DayWeek(InDate$)
  FOR count = 1 TO number
    READ temp$
  NEXT
  FUNCTION = temp$ + CHR$(32)
END FUNCTION

FUNCTION DaysInMonth(InDate$) AS INTEGER
  RESTORE daysinmonthdata
  number = VAL(LEFT$(InDate$, 2))
  FOR count = 1 TO number
    read total
  NEXT
  IF number = 2 THEN total = total + LeapYear(MID$(InDate$, 7))
  FUNCTION = total
END FUNCTION

FUNCTION DateText(InDate$) AS STRING
  day$ = MID$(InDate$, 4, 2) + CHR$(32)
  IF ASC(day$) = 48 THEN day$ = MID$(day$, 2)      ' skip leading zero
  year = VAL(MID$(InDate$, 7))                     ' perhaps < 1
  IF year < 1 THEN
    DECR year
    year$ = rgtALIGN(STR$(ABS(year)), 4)
    REPLACE CHR$(32) WITH "" IN year$
    year$ = year$ + " b.C."
  ELSE
    year$ = MID$(InDate$, 7)
  END IF
  FUNCTION = DayName(InDate$) + day$ + MonthName(InDate$) + year$
END FUNCTION

FUNCTION DateNumeric(InDate$) AS STRING
  year = VAL(MID$(InDate$, 7))                     ' perhaps < 1
  IF year < 1 THEN
    DECR year
    year$ = rgtALIGN(STR$(ABS(year)), 4)
    REPLACE CHR$(32) WITH "0" IN year$
    year$ = "-" + year$
  ELSE
    year$ = MID$(InDate$, 7)
  END IF
  ' uses slash for "-" to avoid "--" in negative year
  FUNCTION = LEFT$(InDate$, 2) + "/" + MID$(InDate$, 4, 2) + "/" + year$
END FUNCTION

' ******************************************************************
' the following routines only serve this demo
' let them out if you intend tot implement the above in your library
' ******************************************************************

SUB JulianText
  CLS
  PRINT "The Julian& (to define as a LONG INTEGER) is a unique number"
  PRINT "for each day, starting November 25, 4714 before Christ; which"
  PRINT "date is Julian (or daynumber) 1."
  PRINT "Keep always in mind that this scientific method to cumpute"
  PRINT "days and dates, is based upon our modern (so called Gregorian)"
  PRINT "calendar. Due to the fact that this calendar is rather young,"
  PRINT "the results may not always mirror historical reality, simply"
  PRINT "because ";CHR$(34);"they";CHR$(34);" used a different ";
  PRINT "calendar in those days."
  PRINT "Additionally, the same must be said of Zeller's method to find the"
  PRINT "name of the day for a given date (FUNCTION DayWeek)."
  PRINT
  PRINT "For computing reasons the Julian method includes the year 0 (zero)"
  PRINT "which was non-existing, they say. That's why the FUNCTIONs DateText"
  PRINT "and DateNumeric have been added in order to correct the result of"
  PRINT "SUB JulToDate by 1 year, if necessary."
  PRINT "If you intend to let the user input dates, your input routine must"
  PRINT "in fact do the opposite. Take care that the routine does not accept"
  PRINT "year zero and no dates older than 11/25/-4714. Before starting"
  PRINT "computational routines your program must INCREASE every input"
  PRINT "older than annum 1 by one year."
  PRINT
  PRINT "more"
  DO
  LOOP UNTIL LEN(INKEY$)
  PRINT
  PRINT "E.g. if the user types ";CHR$(34);"01/01/-0001";CHR$(34);
  PRINT " (January 1st, 1 b.C.) your"
  PRINT "program must modify this into ";CHR$(34);"01/01/0000";CHR$(34);
  PRINT " before passing it"
  PRINT "through any of the above mentioned routines. Afterwards"
  PRINT "FUNCTION DateText or FUNCTION DateNumeric will re-convert it"
  PRINT "to 1 b.C. This sounds rather complicated, but the alternative"
  PRINT "is worse: leave the conversion out and learn your customer/user"
  PRINT "to input zero if he/she means 1 b.C. (etcetera)"
  DO
  LOOP UNTIL LEN(INKEY$)
END SUB

SUB MenuText
  CLS
  PRINT "Date and time manipulations you'll ever need"
  PRINT "Donated to the Public Domain by Egbert Zijlema"
  PRINT
  PRINT "F1  = Info on Julian and Zeller's method"
  PRINT "F2  = Demo leap year"
  PRINT "F3  = Demo Julian"
  PRINT "F4  = Demo ";CHR$(34);"date before Christ";CHR$(34)
  PRINT "F5  = Daylight Saving demo"
  PRINT "Esc = Stop this demonstration"
  PRINT
  PRINT "Re-enter this menu by pressing any key"
END SUB

SUB LeapYearDemo
  CLS
  TestDate$ = "02-01-1996"
  PRINT "1996 is a leap year, so "; MonthName(TestDate$);
  PRINT "counted ";TRIM(STR$(DaysInMonth(TestDate$)));" days"

  TestDate$ = "02-01-1995"
  PRINT "1995 was not, so "; MonthName(TestDate$);"of that year had ";
  PRINT TRIM(STR$(DaysInMonth(TestDate$)));" days"

  DO
  LOOP UNTIL LEN(INKEY$)
END SUB

SUB JulianDemo
  CLS
  PRINT "Today's Julian number is"; Julian&(DATE$)
  PRINT

  TermToPay& = 14
  JulToDate Julian&(DATE$) + TermToPay&, payday$
  PRINT "Pay your bill before "; DateText(payday$)
  PRINT

  JulToDate Julian&(DATE$) - 1, result$
  PRINT "Yesterday was "; DayName(result$); DateNumeric(result$)
  PRINT

  JulToDate 1, oldest$
  PRINT "The oldest date Julian can find is "; DateText(oldest$)
  PRINT "which has been";Julian&(DATE$) - 1; "days ago!"
  PRINT

  PRINT "Dates beyond "; DateText("12-31-9999"); " need computers with the"
  PRINT "capability to store 5-digit years"
  PRINT "Engineers still have plenty of time to invent them:";
  PRINT Julian&("12-31-9999") - Julian&(DATE$); "days"
  DO
  LOOP UNTIL LEN(INKEY$)
END SUB

SUB BeforeChristDemo
  CLS
  TestDate$ = "01-01--0001"                  ' = the year 2 before Christ
  JulToDate Julian&(TestDate$), result$

  PRINT "The year zero did not exist. Probably."
  PRINT "However, for correct computations with Julians you do need it!"
  PRINT "Therefore the FUNCTIONs DateText(InDate$) / DateNumeric(InDate$)"
  PRINT "decrease an annum under 1 (= before Christ) by 1 year."
  PRINT "DateText adds the extension ";CHR$(34);"b.C.";CHR$(34);" as well."
  PRINT
  PRINT "This is the computational date:  "; result$
  PRINT "And here are 3 ways to write it: "; DateText(result$)
  PRINT "                                 "; DayName(result$);
  PRINT DateNumeric(result$)
  PRINT "                                 ";DateNumeric(result$)
  PRINT
  PRINT "BTW: 2 before Christ was ";
  IF NOT LeapYear("0001") THEN PRINT "not";
  PRINT " a leap year"
  DO
  LOOP UNTIL LEN(INKEY$)
END SUB

SUB DayLightDemo
  CLS
  IF BIT(pbvHost, 5) <> 0 THEN
    PRINT "Don't try this in the IDE! It will affect PB.EXE"
    PRINT "Compile this program to an EXE first"
  ELSE
    PRINT "Now we do the daylight saving test"
    PRINT

    JulToDate DayLightBegin&, start$
    JulToDate DayLightEnd&, finish$
    PRINT "The daylight saving half year started "; DateText(start$); " and"
    PRINT "wil end "; DateText(finish$)
    PRINT
    DayLightSaving                            ' install setting on first use

    OldDate$ = DATE$                          ' save actual date
    PRINT "Today: "; DateText(OldDate$);
    PRINT " ("; TIME$; ")"
    PRINT

    JulToDate DayLightBegin& - 1, result$     ' try the day before
    DATE$ = result$
    DayLightSaving
    PRINT "No daylight saving: ";
    PRINT DateText(DATE$); " ("; TIME$; ")"
    PRINT

    JulToDate DayLightBegin& + 1, result$     ' 2 days later
    DATE$ = result$
    DayLightSaving
    PRINT "Daylight saving: ";
    PRINT DateText(DATE$); " ("; TIME$; ")"
    PRINT

    DATE$ = OldDate$                          ' finally restore actual date
    DayLightSaving
    PRINT "Date restored: ";
    PRINT DateText(DATE$); " ("; TIME$; ")"
  END IF
  DO
  LOOP UNTIL LEN(INKEY$)
END SUB

FUNCTION GetKey
  DO
    KeyIn$ = INKEY$
  LOOP UNTIL LEN(KeyIn$)
  FUNCTION = CVI(KeyIn$ + CHR$(0) )
END FUNCTION

SUB MainMenu
  DO
    KeyIn = GetKey
    SELECT CASE KeyIn
      CASE 59 * 256       ' F1
        JulianText
        MenuText
      CASE 27             ' Escape
        CLS : SYSTEM
      CASE 60 * 256       ' F2
        LeapYearDemo
        MenuText
      CASE 61 * 256       ' F3
        JulianDemo
        MenuText
      CASE 62 * 256       ' F4
        BeforeChristDemo
        MenuText
      CASE 63 * 256       ' F5
        DayLightDemo
        MenuText
    END SELECT
  LOOP
END SUB

CLS
  MenuText
  MainMenu
END