Power-Programmierung/CD1.mdf/pascal/library/dos/io/io_23/date23.pas

Pascal/Delphi Source File | 1987-12-04 | 21KB | 701 lines

{ DAT23.U -- Routines to write, read and compare dates, etc.,
  by Bill Meacham.  Turbo Pascal ver. 3.0.
  You must include IO23.INC before this file.
  Ver 2.0 --  Includes type declarations in this module and allows
              entry of a null date (00/00/0000) -- 1/19/86.
              Cosmetic improvement -- 4/16/86.
  Ver 2.1 --  Function Zeller to determine the day of the week -- 10/8/86.
  Ver 2.1a -- New Read_date -- 10/11/86
  Ver 2.2 --  Made compatible with IO22.INC
  Ver 2.3 --  Changed beep to error_buzz -- 11/25/87
              Added proc Getdate to get DOS date,
              Fixed bug in Read_date -- 11/27/87
              Converted to Unit -- 12/2/87 }

{ -------------------------------------------------------------------------- }

unit date23 ;
{$v-}
interface

uses
    crt, dos, io23unit ;

const
    fdslen     = 29 ;  { length of fulldatestring }

type
    date = record
        yr : integer ; { 0 .. 9999 }
        mo : integer ; { 1 .. 12 }
        dy : integer ; { 1 .. 31 }
      end ;

    datestring = string[10] ;  { 'MM/DD/YYYY' }

    fulldatestring = string[fdslen] ;

    juldate = record
        yr  : integer ; { 0 .. 9999 }
        day : integer ; { 1 .. 366 }
      end ;

    juldatestring = string[8] ; { 'YYYY/DDD' }

const
    null_date  : date       = (yr:0 ; mo:0 ; dy:0) ;
    null_date_str : datestring = 'MM/DD/YYYY' ;

function mk_dt_st (dt : date) : datestring ;
  { Makes a string out of a date -- used for printing dates }
procedure write_date (dt: date ; col, row: integer) ;
  { Writes date at column and row specified }
function mk_jul_dt_st (jdt : juldate) : juldatestring ;
  { makes a string out of a julian date }
function leapyear (yr : integer) : boolean ;
  { Whether the year is a leap year or not.
    The year is year and century, e.g. year 1984 is '1984,' not '84' }
function valid_date (dt:date) : boolean ;
  { Test whether date is valid }
procedure read_date (var dt: date ; col, row: integer) ;
  { Read date at column and row specified.  If the user enters only
    two digits for the year, the procedure plugs the century as 1900 or
    2000, but the user can enter all four digits to override the plug. }
function greater_date (dt1, dt2 : date) : integer ;
  { Compares two dates, returns 0 if both equal, 1 if first is
    greater, 2 if second is greater. }
procedure greg_to_jul (dt : date ; var jdt : juldate) ;
  { converts a gregorian date to a julian date }
procedure jul_to_greg (jdt : juldate ; var dt : date) ;
  { converts a julian date to a gregorian date }
procedure next_day (var dt : date) ;
  { Adds one day to the date }
procedure prev_day (var dt : date) ;
  { Subtracts one day from the date }
function date_diff (dt1, dt2 : date) : real ;
  { computes the number of days between two dates }
function month_diff (dt1, dt2 : date ) : integer ;
  { Computes number of months between two dates, rounded. }
function equal_date (dt1, dt2 : date) : boolean ;
  { Tests whether two dates are equal }
function build_full_date_str (dt : date) : fulldatestring ;
  { Build printable string of current date. }
procedure getdate (var dt : date) ;
  { get DOS system date }
function date_and_time : str14 ;
  { get DOS system date and time, return string }

{ ========================================================================== }

implementation

type
   montharray = array [1 .. 13] of integer ;

const
   monthtotal : montharray = (0,31,59,90,120,151,181,212,243,273,304,334,365) ;
     { used to convert julian date to gregorian and back }

{ ------------------------------------------------------------ }

function mk_dt_st (dt : date) : datestring ;
  { Makes a string out of a date -- used for printing dates }
    var
        yr_st : string[4] ;
        mo_st : string[2] ;
        dy_st : string[2] ;
        dt_st : datestring ;
    begin
        with dt do
          begin
            if (yr=0) and (mo=0) and (dy=0) then
                dt_st := 'MM/DD/YYYY'
            else
              begin
                str (yr:4,yr_st) ;
                str (mo:2,mo_st) ;
                str (dy:2,dy_st) ;
                dt_st := concat (mo_st,'/',dy_st,'/',yr_st)
              end  { else }
          end ;  { with dt do }
        mk_dt_st := dt_st
    end ;  { --- proc mk_dt_st --- }

{ ------------------------------------------------------------ }

procedure write_date (dt: date ; col, row: integer) ;
  { Writes date at column and row specified }
    var
        ds : datestring ;
    begin
        ds := mk_dt_st (dt) ;
        write_str (ds,col,row)
    end ; { --- proc write_date --- }

{ ------------------------------------------------------------ }

function mk_jul_dt_st (jdt : juldate) : juldatestring ;
{ makes a string out of a julian date }
  var
      yr_st  : string[4] ;
      day_st : string[3] ;
      jdt_st : juldatestring ;
  begin
      with jdt do
        if (yr=0) and (day = 0) then
            jdt_st := 'YYYY/DDD'
        else
          begin
            str(yr:4,yr_st) ;
            str(day:3,day_st) ;
            jdt_st := concat (yr_st,'/',day_st)
          end ;
      mk_jul_dt_st := jdt_st
  end ;  { function mk_jul_dt_st }

{ ------------------------------------------------------------ }

function leapyear (yr : integer) : boolean ;
  { Whether the year is a leap year or not.
    The year is year and century, e.g. year 1984 is '1984,' not '84' }
  begin
    leapyear := ((yr mod 4 = 0) and (not(yr mod 100 = 0)))
             or ( yr mod 400 = 0 )
  end ;

{ ------------------------------------------------------------ }

function valid_date (dt:date) : boolean ;
  { Test whether date is valid }
    var
        bad_fld : integer ;
    begin
        bad_fld := 0 ;
        with dt do
            begin
                if (mo = 0) and (dy = 0) and (yr = 0) then
                    bad_fld := 0
                else if not (mo in [1 .. 12]) then
                        bad_fld := 1
                else if (dy > 31)
                or (dy < 1)
                or ((mo in [4,6,9,11]) and (dy > 30)) then
                        bad_fld := 2
                else if mo = 2 then
                  begin
                    if (leapyear(yr) and (dy > 29))
                    or ((not leapyear(yr)) and (dy > 28)) then
                        bad_fld := 2
                  end
                else if yr = 0 then
                        bad_fld := 3
            end ; { with dt do }
        valid_date := (bad_fld = 0)
    end ; { function valid_date }

{ ------------------------------------------------------------ }

procedure read_date (var dt: date ; col, row: integer) ;

{ Read date at column and row specified.  If the user enters only
  two digits for the year, the procedure plugs the century as 1900 or
  2000, but the user can enter all four digits to override the plug. }

  var
    ch       : char ;
    savex,
    savey,
    savefld,
    bad_fld,
    key,
    p        : integer ;
    s,
    template : datestring ;

{ ==================== }

  procedure add_to_str ;
    var
      l : integer ;
    begin
      l := length(s) ;
      if l = 10 then
          error_buzz
      else if (l=1) or (l=4) then
        begin
          s := concat(s,ch,'/') ;
          write (ch,'/')
        end
      else
        begin
          s := concat(s,ch) ;
          write (ch)
        end
    end ; { proc add_to_str }

{ ==================== }

  procedure adjust_dt_str ;
    var
      l : integer ;
    begin
      case key of
        del_fld :
          begin
            s := '' ;
            write_str (template,col,row) ;
            gotoxy (col,row)
          end ;
        del_left,
        prev_char :                    { prev_char is destructive backspace! }
          begin
            l := length(s) ;
            if l = 0 then
                error_buzz
            else if (l=3) or (l=6) then
              begin
                write (^H,^H,chr(filler),^H) ;
                delete (s,l-1,2)
              end
            else
              begin
                write (^H,chr(filler),^H) ;
                delete (s,l,1)
              end
          end
      end { case }
    end ; { proc adjust_dt_str }

{ ==================== }

  procedure convert_date ;
  { convert the string to a date -- three integers }
    var
      code : integer ;
    begin
      p := pos(' ',s) ;
      while p <> 0 do
        begin
          s[p] := '0' ;
          p := pos(' ',s)
        end ;
      with dt do
        begin
          if (copy(s,1,2) = '') then
            begin
              mo := 0 ; code := 0
            end
          else
              val (copy(s,1,2),mo,code) ;
          if code <> 0 then
            begin
              write ('** CONVERSION ERROR ',code) ;
              halt
            end ;
          if (copy(s,4,2) = '') then
            begin
              dy := 0 ; code := 0
            end
          else
              val (copy(s,4,2),dy,code) ;
          if code <> 0 then
            begin
              write ('** CONVERSION ERROR ',code) ;
              halt
            end ;
          if (copy(s,7,4) = '') then
            begin
              yr := 0 ; code := 0
            end
          else
              val (copy(s,7,4),yr,code) ;
          if code <> 0 then
            begin
              write ('** CONVERSION ERROR ',code) ;
              halt
            end ;
          if not ((yr = 0) and (mo = 0) and (dy = 0)) then
            begin                                          { plug century }
              if yr < 80 then
                  yr := 2000 + yr
              else if yr < 100 then
                  yr := 1900 + yr
            end
        end { with }
    end ; { proc convert_date}

{ ==================== }

  procedure edit_date ;                  { Edit for valid date }
    begin
      bad_fld := 0 ;
      with dt do
        begin
          if (mo = 0) and (dy = 0) and (yr = 0) then
              bad_fld := 0
          else if not (mo in [1 .. 12]) then
              bad_fld := 1
          else if (dy > 31)
          or (dy < 1)
          or ((mo in [4,6,9,11]) and (dy > 30)) then
              bad_fld := 2
          else if mo = 2 then
            begin
              if (leapyear(yr) and (dy > 29))
              or ((not leapyear(yr)) and (dy > 28)) then
                  bad_fld := 2
            end
          else if yr = 0 then
              bad_fld := 3
        end   { with dt do }
    end ; { proc edit_date }

{ ==================== }

  procedure display_date ;               { write date on screen }
    begin
    if (dt.mo = 0) and (dt.dy = 0) and (dt.yr = 0) then
      begin
        write_str (template,col,row) ;
        s := '' ;
        gotoxy (col,row)
      end
    else
      begin
        s := mk_dt_st(dt) ;
        p := pos(' ',s) ;
        while p <> 0 do
          begin
           s[p] := '0' ;
            p := pos(' ',s)
          end ;
        write_str (s,col,row)
      end
    end ;  { proc display_date }

{ ==================== }

begin { proc read_date }
  savefld := fld ;
  ch := chr(filler) ;
  template := concat(ch,ch,'/',ch,ch,'/',ch,ch,ch,ch) ;
  display_date ;
  repeat
      keyin(ch) ;
      key := ord(ch) ;
      if ch in ['0'..'9'] then
          add_to_str
      else if key in adjusting then
          adjust_dt_str
      else if key in terminating then
        begin
          convert_date ;
          edit_date ;
          do_fld_ctl (key) ;
          if bad_fld <> 0 then                  { error message only if }
            begin                               { going forward }
              if (fld < maxint) and (fld > savefld) then
                begin
                  savex := wherex ;
                  savey := wherey ;
                  case bad_fld of
                    1 : show_msg ('INVALID MONTH') ;
                    2 : show_msg ('INVALID DAY') ;
                    3 : show_msg ('INVALID YEAR')
                  end ; { case }
                  fld := savefld ;              { if bad date, may not go foward }
                  gotoxy (savex,savey)          { restore cursor position }
                end
            end
        end
      else                                      { invalid character }
          error_buzz
  until not (fld = savefld) ;
  if (bad_fld <> 0) then                        { if bad date, zero it out }
      dt := null_date ;
  write_date (dt,col,row)
end ; { proc read_date }

{ ------------------------------------------------------------ }

function greater_date (dt1, dt2 : date) : integer ;
  { Compares two dates, returns 0 if both equal, 1 if first is
    greater, 2 if second is greater.  Converts both to strings,
    then compares the strings. }

    var
        stdt1, stdt2 : string[8] ;
        styr1, styr2 : string[4] ;
        stmo1, stmo2 : string[2] ;
        stdy1, stdy2 : string[2] ;

    begin
        with dt1 do
            begin
                str(yr:4,styr1) ;
                str(mo:2,stmo1) ;
                str(dy:2,stdy1) ;
                stdt1 := concat (styr1,stmo1,stdy1)
            end ;
        with dt2 do
            begin
                str(yr:4,styr2) ;
                str(mo:2,stmo2) ;
                str(dy:2,stdy2) ;
                stdt2 := concat (styr2,stmo2,stdy2)
            end ;
        if stdt1 > stdt2 then
                greater_date := 1
        else if stdt2 > stdt1 then
                greater_date := 2
        else { both equal }
                greater_date := 0
    end ; { --- of greater_date --- }

{ ------------------------------------------------------------ }

procedure greg_to_jul (dt : date ; var jdt : juldate) ;
{ converts a gregorian date to a julian date }
  begin
    jdt.yr := dt.yr ;
    if (dt.yr = 0) and (dt.mo = 0) and (dt.dy = 0) then
        jdt.day := 0
    else
      begin
        if (leapyear(dt.yr)) and (dt.mo > 2) then
            jdt.day := 1
        else
            jdt.day := 0 ;
        jdt.day := jdt.day + monthtotal[dt.mo] + dt.dy
      end
  end ;  { --- procedure greg_to_jul --- }

{ ------------------------------------------------------------ }

procedure jul_to_greg (jdt : juldate ; var dt : date) ;
{ converts a julian date to a gregorian date }
  var
      i, workday : integer ;
  begin
    dt.yr := jdt.yr ;
    if (jdt.yr = 0) and (jdt.day = 0) then
      begin
        dt.mo := 0 ; dt.dy := 0
      end
    else
      begin
        workday := jdt.day ;
        if (leapyear(jdt.yr)) and (workday > 59) then
            workday := workday - 1 ;   { make it look like a non-leap year }
        i := 1 ;
        repeat
            i := i + 1
        until not (workday > monthtotal[i]) ;
        i := i - 1 ;
        dt.mo := i ;
        dt.dy := workday - monthtotal[i] ;
        if leapyear(jdt.yr) and (jdt.day = 60) then
            dt.dy := dt.dy + 1
      end
  end ;  { --- procedure jul_to_greg --- }

{ ------------------------------------------------------------ }

procedure next_day (var dt : date) ;
  { Adds one day to the date }
    var
        jdt  : juldate ;
        leap : boolean ;
    begin
        greg_to_jul (dt,jdt) ;
        jdt.day := jdt.day + 1 ;
        leap := leapyear (dt.yr) ;
        if (leap and (jdt.day = 367))
        or (not leap and (jdt.day = 366)) then
          begin
            jdt.yr := jdt.yr + 1 ;
            jdt.day := 1
          end ;
        jul_to_greg (jdt,dt)
    end ;  { --- procedure next_day --- }

{ ------------------------------------------------------------ }

procedure prev_day (var dt : date) ;
  { Subtracts one day from the date }
    var
        jdt : juldate ;
    begin
        greg_to_jul (dt,jdt) ;
        jdt.day := jdt.day - 1 ;
        if jdt.day < 1 then
          begin
            jdt.yr := jdt.yr - 1 ;
            if leapyear (jdt.yr) then
                jdt.day := 366
            else
                jdt.day := 365
          end ;
        jul_to_greg (jdt,dt)
    end ;  { --- procedure prev_day --- }

{ ------------------------------------------------------------ }

function date_diff (dt1, dt2 : date) : real ;
  { computes the number of days between two dates }
    var
        jdt1, jdt2 : juldate ;
        i, num_leap_yrs : integer ;
    begin
        greg_to_jul (dt1, jdt1) ;
        greg_to_jul (dt2, jdt2) ;

        num_leap_yrs := 0 ;         { adjust for leap years }
        if dt2.yr > dt1.yr then
          begin
            for i := dt1.yr to dt2.yr - 1 do
                if leapyear(i) then
                    num_leap_yrs := num_leap_yrs + 1
          end
        else if dt1.yr > dt2.yr then
          begin
            for i := dt2.yr to dt1.yr - 1 do
                if leapyear(i) then
                    num_leap_yrs := num_leap_yrs - 1
          end ;

        date_diff := jdt2.day - jdt1.day + ((jdt2.yr - jdt1.yr) * 365.0) + num_leap_yrs
    end ;

{ ------------------------------------------------------------ }

function month_diff (dt1, dt2 : date ) : integer ;
  { Computes number of months between two dates, rounded.
    30.4167 = 356/12, average number of days in a month. }
    begin
        month_diff := round((date_diff(dt1, dt2) + 1) / 30.4167)
    end ;

{ ------------------------------------------------------------ }

function equal_date (dt1, dt2 : date) : boolean ;
  { Tests whether two dates are equal }
    begin
        equal_date := (dt1.mo = dt2.mo) and (dt1.dy = dt2.dy)
                      and (dt1.yr = dt2.yr)
    end ;

{ ------------------------------------------------------------ }

function zeller (dt : date) : integer ;
{ Compute the day of the week using Zeller's Congruence.
  From ROS 3.4 source code }
  var
    century: integer ;
  begin
    with dt do
      begin
        if mo > 2
          then mo := mo - 2
          else
            begin
              mo := mo + 10 ;
              yr := pred(yr)
            end ;
        century := yr div 100 ;
        yr := yr mod 100 ;
        zeller := (dy - 1 + ((13 * mo - 1) div 5) + (5 * yr div 4) +
            century div 4 - 2 * century + 1) mod 7
      end
  end ;  { function zeller }

{ ------------------------------------------------------------ }

function build_full_date_str (dt : date) : fulldatestring ;
{ Build printable string of current date -- from ROS 3.4 source code. }
  const
    day: array [0..6] of string[6] =
      ('Sun','Mon','Tues','Wednes','Thurs','Fri','Satur') ;
    month: array [1..12] of string[9] =
      ('January','February','March','April','May','June','July','August','September','October','November','December') ;
  var
    i: integer ;
    s: fulldatestring ;

  function intstr(n, w: integer): str_type ;
  { Return a string value of width w for the input integer n }
    var
      st: str_type ;
    begin
      str(n:w, st) ;
      st := purgech (st,' ') ;
      intstr := st
    end ;

  begin { build_full_date_str }
    with dt do
      begin
        if  (mo = 0) and (dy = 0) and (yr = 0) then
            s := 'No Date'
        else
            s := day[zeller(dt)] + 'day, ' +
                 month[mo] + ' ' + intstr(dy, 2) + ', ' + intstr(yr, 4) ;
        if length (s) < fdslen then
            s := pad (s,' ',fdslen)
      end ;
    build_full_date_str := s
  end ; { function build_full_date_str }

{ ----------------------------------------------------------------- }

procedure getdate (var dt : date) ;
  { get DOS system date }

    var regs : registers ;

    begin
      with regs do
        begin
          AX := $2A00 ;
          msdos(regs) ;
          dt.yr := CX ;
          dt.mo := DH ;
          dt.dy := DL
        end
    end ; { proc getdate }

{ ----------------------------------------------------------------- }

function date_and_time : str14 ;
  { get DOS system date and time, return string }

var
  year,
  month,day,
  hour,min  : string[2] ;
  regs : registers ;

begin
  with regs do
    begin
      AX := $2A00 ;
      msdos(regs) ;
      str(CX-1900,year) ;
      str(DH,month) ;
      str(DL,day) ;
      AX := $2C00 ;
      msdos (regs) ;
      str(CH:2,hour) ;
      str(CL:2,min) ;
    end ;
  if  min[1] = ' ' then  min[1] := '0' ;
  if  (hour[1] = ' ')
  and (hour[2] = '0') then
      hour := '00' ;
  date_and_time := concat (month,'/',day,'/',year,' ',hour,':',min) ;
end ; { function getdate }

end. { implementation }

{ ----- EOF DAT23.U ------------------------------------------ }