Power-Programmierung/CD1.mdf/pascal/library/dos/t_power/calendar.pas

Pascal/Delphi Source File | 1988-02-08 | 17.2 KB | 629 lines

(***********************************************************************)
(*                                                                     *)
(*                     TURBO CALENDAR FUNCTIONS                        *)
(*                                                                     *)
(*                                                                     *)
(*                       Module version 1.01A                          *)
(*                                                                     *)
(*                         by Rick Amerson                             *)
(*                                                                     *)
(*                                                                     *)
(*                                                                     *)
(*                                                                     *)
(*                                                                     *)
(***********************************************************************)
unit Calendar;

interface

uses Dos,
     Crt,
     TpString;

const
    BaseYear         =  1901;    {Must start year after leap year}
    MaxHoliday       =  400;     {Maximum number of entries in holiday file }
    InvalidDate      =  $FFFF;   {Invalid Date}

type
    DayOfWeek        =  (Sunday, Monday, Tuesday, Wednesday,
                         Thursday, Friday, Saturday);
    DateNum          =  word;   {Date Number-- compressed two byte date}
    DateArray        =  array[1..MaxHoliday] of DateNum;
    CalendarPtr      =  ^CalendarRec;
    CalendarRec      =  record
                          CalName:  string[8];
                          LastH,      {Last holiday entry}
                          LastE:  integer;    {Last entry in extra array}
                          Workdays: set of DayOfWeek;
                          WorkdaysPerWeek: 0..7;
                          HDate: DateArray;
                          EDate: DateArray;
                          end;

const
    MonthName: array[1..12] of string[9]=
           ('January', 'February', 'March', 'April', 'May', 'June',
            'July', 'August', 'September', 'October', 'November', 'December');
    DayName: array[DayOfWeek] of string[9]=
             ('Sunday', 'Monday', 'Tuesday', 'Wednesday',
              'Thursday', 'Friday', 'Saturday');


function ToDateNum(D: DateTime): DateNum;
{This function returns the integer equivalent of a date passed to it}

procedure FromDateNum(D_In: DateNum;
                  var D:    DateTime);

{This function converts from a DateNum format date to DateTime}

function Today: DateNum;    {returns today's date as a DateNum}

function LotusDate(D: DateNum): string;
{Returns a string formatted as  12-Jul-88.  If date = 0, returns blank string}

function FromLotusDate(S: string): DateNum;
{Reads a date from any of the following formats:

      1: DD-MMM-YY
      2: DD-MMM         --Assumes current year
      3: MMM-YY         --Assumes first of month
      4: MM/DD/YY
      5: MM/DD          --Assumes current year
      6: MMM DD, YYYY
}

function ExtDate(D: DateNum): string;
{ returns date of format:   Fri, Aug 28, 1987 }

function ExtTime( T: word ): string;
{returns time of format:  12:46 PM}

function TimeStr( T: DateNum ): string;
{returns a string with the time T in 12-hour format "10:43 PM"}

function ToMMDDYY(D: DateNum): string;
{Returns string of format:  030288   (MonthDayYear)}

function FromMMDDYY(S: string): DateNum;
{Decodes string of format:   030288   (MonthDayYear)}

function ToDDMMYY(D: DateNum): string;
{Returns string of format:  020388  (DayMonthYear)}

function FromDDMMYY(S: string): DateNum;
{Decodes string of format:   030288   (DayMonthYear)}

function HolidaysBetween( D1,
                          D2: DateNum;
                          var Calendar: CalendarPtr ): integer;
{Return Number of Holidays between D1 and D2}

function WorkDaysBetween( D1, D2: DateNum;
                          var Calendar: CalendarPtr ): integer;
{Return Number of WorkDays between D1 and D2}

procedure SetDate(NewDate: DateNum);    {sets today's date as an integer}

function TimeNow: word; {returns current time as integer minutes since 0:00}

procedure GetTime( var Minutes,
                       Seconds: word); {gets current time as mins since 0:00}

procedure SetTime( Minutes,
                   Seconds: word); {sets current time as minutes since 0:00}

function ValidDate( D: DateTime ): boolean; {Returns true if date is valid}

{===========================================================================}
{.pa}
implementation

const
  Digits: set of char   = ['0'..'9'];
  DayOffset        =  1;       {Constant to add for day of week}
  DaysInYear       =  365.25;
  MonthsInYear     =  12;
  DaysIn: array[1..12] of byte        =  (31, 29, 31, 30, 31, 30,
                                          31, 31, 30, 31, 30, 31);
  DaysBefore: array[1..12] of integer =   (0, 31, 60, 91,121,152,
                                         182,213,244,274,305,335);

type
  str2 = string[2];

function Str2Lead0( B: byte ): str2;

begin

  Str2Lead0[0] := #2;   {two byte result}
  Str2Lead0[1] := chr((B div 10) + ord('0'));
  Str2Lead0[2] := chr((B mod 10) + ord('0'));

  end;

function Str2LeadBlank( B: byte ): str2;

begin

  Str2LeadBlank[0] := #2;   {two byte result}
  if (B div 10) = 0 then Str2LeadBlank[1] := ' '
  else Str2LeadBlank[1] := chr((B div 10) + ord('0'));
  Str2LeadBlank[2] := chr((B mod 10) + ord('0'));

  end;

function ValidDate( D: DateTime ): boolean; {Returns true if date is valid}

begin

  with D do begin
    ValidDate := false;
    case Year of
      1901..2079: case Day of
        1..31: case Month of
          1, 3..12: if Day <= DaysIn[Month] then ValidDate := true;
          2:        if Day <= 28 + ord(Year mod 4 = 0) then ValidDate := true;
          end;  {case Month}
        end;  {case Day}
      end;  {case Year}
    end;  {with D}

  end;  {ValidDate}

function ToDateNum(D: DateTime): DateNum;
{This function returns the integer equivalent of a date passed to it}

var T: integer;

begin

  T := DaysBefore[D.Month] + D.Day +                  {Days in this year}
    trunc( DaysInYear * (D.Year - BaseYear));         {Days in prior years}
  if ( ( D.Year and $3 ) <> 0 ) and ( D.Month > 2 ) then Dec(T);
                                    { Subtract Leap Day for non-leap years}
  ToDateNum := T;
  end;
{.pa}
procedure FromDateNum(D_In: DateNum;
                  var D:    DateTime);

{This function converts from a DateNum format date to DateTime}

var T: integer;

begin

  with D do begin
    T := trunc( D_In / DaysInYear );     {Number of prior years}
    D_In := D_In - trunc( T * DaysInYear ); {Day in year-- 1..366}
    Year := T + BaseYear;
    if (( Year and $3 ) <> 0 ) and ( D_In >= DaysBefore[3] ) then Inc( D_In);
                                      {Add in Feb 29 for non-leap years}
    Month := ( D_In - 1 ) div 31 + 1;  {Approximate month}
    if ( D_In > DaysBefore[Month] + DaysIn[Month] ) then Inc(Month);
    Day := D_In - DaysBefore[Month];
    end; {with D do}

  end; {CalDate}
{.pa}
function Today: DateNum;    {returns today's date as a DateNum}

var Reg: Registers;
    TDate: DateTime;

begin

  with Reg, TDate do begin
    AH := $2A;
    MSDos( Reg );
    Month := DH;
    Day := ( DL );
    Year := ( CX );
    Today := ToDateNum( TDate );
    end;  {with Reg, TDate do}

  end; {Today}

function LotusDate(D: DateNum): string;
{Returns a string formatted as  12-Jul-88.  If date = 0, returns blank string}

var
  TDate: DateTime;

begin {LotusDate}
  if D = InvalidDate then
    LotusDate := '*Invalid*'
      else begin
    FromDateNum(D,TDate);
    with TDate do begin
      LotusDate := Str2Lead0( Day ) + '-' + copy(MonthName[Month],1,3) + '-' +
        Str2Lead0( Year mod 100 );
      end; {with TDate}
    end; {else D = 0}
  end; {LotusDate}
{.pa}
function FromLotusDate(S: string): DateNum;
{Reads a date from any of the following formats:

      1: DD-MMM-YY
      2: DD-MMM         --Assumes current year
      3: MMM-YY         --Assumes first of month
      4: MM/DD/YY
      5: MM/DD          --Assumes current year
      6: MMM DD, YYYY
}

type
  DateFormat = set of 1..6;

const
  Separators: set of char = ['-', '/', ' ', ','];  {Valid separator characters}

var
  Format:    DateFormat;
  TDate:     DateTime;
  Junk:      word;

function FindMonth(var Name: string): word;

var
  Month:     byte;
  TName:     string[3];

begin

  Month := 12;
  TName := StLocase( copy(Name,1,3) );
  TName[1] := Upcase( Name[1] );
  while (copy(MonthName[Month], 1, 3) <> TName) and (Month > 0) do dec(Month);
  FindMonth := Month;
  if Month <> 0 then begin
    Name := copy( Name, 4, 255 );
    while (length(Name) > 0) and (Name[1] in Separators) do
      Name := copy(Name, 2, 255);                {Throw away separator char}
    end;

  end; {FindMonth}

function ReadDigits( var S: string ): word;
{Reads a number up to 4 digits}

var
  V:  word;

begin

  V := 0;
  while (length(S) > 0 ) and (S[1] in Digits) and (V <= 999) do begin
    V := V * 10 + ord(S[1]) - ord('0');
    S := copy( S, 2, 255 );
    end;
  ReadDigits := V;
  while (length(S) > 0) and (S[1] in Separators) do
    S := copy(S, 2, 255);                {Throw away separator char}

  end;
{.pa}
begin {FromLotus}

  Format := [1..6];                {could be any format}
  with TDate do begin
    Hour := 0;
    Min := 0;
    Sec := 0;
    Day := ReadDigits( S );
    if Day <> 0 then Format := Format - [3,6]
    else Format := Format - [1,2,4,5];    {format 3 or 6}
    Month := FindMonth(S);
    if Month = 0 then begin
      Format := Format - [1,2,3,6];    {not a valid format}
      Month := Day;
      Day := ReadDigits( S );
      if Day = 0 then Format := Format - [4,5];    {Not a 4 or 5}
      end;
    if length(S) > 0 then begin                 {Look for a year}
      Format := Format - [2,5];
      Year := ReadDigits( S );
      if length(S) > 0 then begin    {must be format 6; this is the day}
        Day := Year;
        Year := ReadDigits( S );
        Format := Format - [1,2,3,4,5];
        end
      else Format := Format - [6];
      if Year < 100 then begin
        Year := Year + 1900;
        if Year < 1901 then Year := Year + 100;
        end;
      end
    else begin
      Format := Format - [1,3,4,6];
      GetDate( Year, Junk, Junk, Junk );   {Use current year}
      end;
    if Format = [3] then Day := 1;  {Default day}
    if (Format <> []) and ValidDate(TDate) then begin
      FromLotusDate := ToDateNum(TDate);
      end
    else begin
      FromLotusDate := InvalidDate;
      end;
    end; {with TDate do}
  end;  {FromLotusDate}

{.pa}
function ExtDate(D: DateNum): string;
{ returns date of format:   Fri, Aug 28, 1987 }

var
  TDate: DateTime;
  S:     string;

begin  {ExtDate}

  if D = InvalidDate then ExtDate := '**** Invalid ****'
  else begin
    FromDateNum(D,TDate);
    with TDate do begin
      str( Year:4, S );
      ExtDate := copy(DayName[DayOfWeek((D+DayOffset) mod 7)],1,3) + ', ' +
        copy(MonthName[Month],1,3) + ' ' + Str2LeadBlank( Day) +  ', ' + S;
      end;
    end;  {if D = InvalidDate}
end;
{.pa}
function ExtTime( T: word ): string;
{returns time of format:  12:46 PM}

var
  Hour,
  Minute:   integer;
  AM_PM:    string[2];
  S:        string;

begin    {ExtTime}

  Hour := T div 60;
  Minute := T mod 60;
  if Hour >= 12 then AM_PM := 'PM' else AM_PM := 'AM';
  Hour := Hour mod 12;
  if Hour = 0 then Hour := 12;
  S := Str2LeadBlank( Hour ) + ':' + Str2Lead0( Minute ) + ' ' + AM_PM;
  if S[4] = ' ' then S[4] := '0';
  ExtTime := S;

  end;   {ExtTime}

function TimeStr( T: DateNum ): string;

var
  S:             string;
  ThisDateTime:  DateTime;

begin

  UnpackTime( T, ThisDateTime );
  with ThisDateTime do begin
    if Hour >= 12 then S := 'P' else S := 'A';
    Hour := Hour mod 12;
    if Hour = 0 then Hour := 12;
    S := Str2Lead0( Min ) + ' ' + S + 'M';
    TimeStr := Str2LeadBlank( Hour ) + ':' + S;
    end;   {with ThisDateTime}

  end;  {TimeStr}

{.pa}
function ToMMDDYY(D: DateNum): string;
{Returns string of format:  030288   (MonthDayYear)}

var TDate: DateTime;
    S:     string;

begin
  FromDateNum(D, TDate);
  with TDate do
    ToMMDDYY := Str2Lead0( ord( Month ) + 1 ) + Str2Lead0( Day ) +
      Str2Lead0( Year mod 100 );
  end;  {ToMMDDYY}

function FromMMDDYY(S: string): DateNum;
{Decodes string of format:   030288   (MonthDayYear)}

var TDate:    DateTime;
    TMonth,
    TYear:    word;

begin

  FromMMDDYY := InvalidDate;
  with TDate do begin
    if Str2Word( copy(S,1,2), Month ) then begin
      if Str2Word( copy(S,3,2), Day ) then begin
        if Str2Word( copy(S,5,2), TYear ) then begin
          TYear := TYear + 1900;
          if TYear < BaseYear then
            TYear := TYear + 100;   {After turn of century}
          Year := TYear;
          FromMMDDYY := ToDateNum( TDate )
          end;
        end;
      end;
    end; {with TDate}
  end;  {FromMMDDYY}

{.pa}
function ToDDMMYY(D: DateNum): string;
{Returns string of format:  020388  (DayMonthYear)}

var TDate: DateTime;
    S:     string;

begin
  FromDateNum(D, TDate);
  with TDate do
    ToDDMMYY := Str2Lead0( Day ) + Str2Lead0( ord( Month ) + 1 ) +
      Str2Lead0( Year mod 100 );
  end;  {ToDDMMYY}

function FromDDMMYY(S: string): DateNum;
{Decodes string of format:   030288   (DayMonthYear)}

begin

  FromDDMMYY := FromMMDDYY(Copy(S,3,2) + copy(S,1,2) + copy(S,5,2));

  end;  {FromDDMMYY}
{.pa}
function HolidaysBetween( D1,
                          D2: DateNum;
                          var Calendar: CalendarPtr ): integer;
{Return Number of Holidays between D1 and D2}

var Top,
    Bot,
    Mid:  integer;

function SearchHoliday( Max:   integer;
                        D:     DateNum;
                        var A: DateArray): integer;
{returns index into DateArray of D such that A[index] >= D}

begin

  Bot := 1;
  Top := Max;

  if Top > 0 then
    repeat
      Mid := ( Top + Bot ) div 2;
      if D <= A[Mid] then
        Top := Mid - 1;
      if D >= A[Mid] then
        Bot := Mid + 1;
      until Top < Bot;

  SearchHoliday := ( Top + Bot ) div 2 + 1;

  end;  {SearchHoliday}

begin  {function HolidaysBetween}

  with Calendar^ do
    HolidaysBetween := Abs( SearchHoliday( LastH, D1, HDate ) -
                            SearchHoliday( LastH, D2, HDate ) ) -
                       Abs( SearchHoliday( LastE, D1, EDate ) -
                            SearchHoliday( LastE, D2, EDate ) );

  end;  {HolidaysBetween}

{.pa}
function WorkDaysBetween( D1, D2: DateNum;
                          var Calendar: CalendarPtr ): integer;
{Return Number of WorkDays between D1 and D2}

var
  WeeksBetween,
  DaysBetween: integer;
  DW,
  DW1,
  DW2: DayOfWeek;

begin
  WeeksBetween := abs( (D2 + DayOffset) div 7 - (D1 + DayOffset) div 7 ) -1;
                                          {Number of whole weeks between}

  with Calendar^ do begin
    DaysBetween := WeeksBetween * WorkDaysPerWeek;
    DW1 := DayOfWeek( (D1 + DayOffset) mod 7 );
    DW2 := DayOfWeek( (D2 + DayOffset) mod 7 );

    if D1 < D2 then begin
      for DW := DW1 to Saturday do
        if DW in WorkDays then
          DaysBetween := succ( DaysBetween );
      for DW := Sunday to DW2 do
        if DW in WorkDays then
          DaysBetween := succ( DaysBetween );
      end {D1 < D2}
    else begin
      for DW := Sunday to DW1 do
        if DW in WorkDays then inc( DaysBetween );
      for DW := DW2 to Saturday do
        if DW in WorkDays then inc( DaysBetween );
      end;
    end; {with Calendar^}

  WorkDaysBetween := DaysBetween - HolidaysBetween( D1, D2, Calendar );
  end;  {WorkDaysBetween}

procedure SetDate(NewDate: DateNum);    {sets today's date as an integer}

var Reg: Registers;
    TDate: DateTime;

begin

  FromDateNum( NewDate, TDate );
  with Reg, TDate do begin
    AH := $2B;
    DH := ord(Month) + 1;
    DL := Day;
    CX := Year;
    MSDos( Reg );
    end;  {with Reg, TDate do}

  end; {SetDate}
{.pa}
function TimeNow: word; {returns current time as integer minutes since 0:00}

var Reg: Registers;

begin

  with Reg do begin
    AH := $2C;
    MSDos( Reg );
    TimeNow := CH * 60 + CL;
    end;  {with Reg do}

  end; {TimeNow}

procedure GetTime( var Minutes,
                       Seconds: word); {gets current time as minutes since 0:00}

var Reg: Registers;

begin

  with Reg do begin
    AH := $2C;
    MSDos( Reg );
    Minutes := CH * 60 + CL;
    Seconds := DH;
    end;  {with Reg do}

  end; {GetTime}

procedure SetTime( Minutes,
                   Seconds: word); {sets current time as minutes since 0:00}

var Reg: Registers;

begin

  with Reg do begin
    AH := $2D;
    CH := Minutes div 60;    {hours}
    CL := Minutes mod 60;    {minutes}
    DH := Seconds;
    DL := 0;         {hundredths of seconds}
    MSDos( Reg );
    end;  {with Reg do}

  end; {SetTime}

begin
  end.