Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/TP5WIO.ZIP/TP5WIO.PAS

Pascal/Delphi Source File | 1989-07-07 | 38.9 KB | 1,159 lines

unit tp5wio;
{ !!!! NOTE: THE FILE TP5MISC.TPU MUST BE COMPILED FIRST !!!!
   -- Global I/O procedures to include in programs generally
  Much credit is due Bill Meacham who wrote the original file IO22.INC
  and released it to the public domain.  Using that work this unit was
  created and added to by Gerald Rohr of Homogenized Software.  As
  with Bill's work, this program is released to the Public Domain for
  all to use and modify.
                       REVISION  HISTORY
  ---------------------------------------------------------------------
  Ver 2.22 Converted to a Turbo pascal V4 units.          30 Dec 87 gbr
  Ver 2.30 Converted dates to longint types               19 Jan 88 gbr
  Ver 2.42 Added global inv_flag for all write routines   08 Apr 88 gbr
  Ver 2.43 Added long integer read and write routines     01 May 88 gbr
  Ver 2.43 Added month and month/day routines             10 May 88 gbr
  Ver 3.00 Replaced Window procedures/Reformated file     15 Jul 88 gbr
  Ver 3.10 Moved Window error routines here               26 Aug 88 gbr
  Ver 3.20 Added code and globals for color hi lights     27 Aug 88 gbr
  Ver 3.21 Fixed leading decimal point in read_real       02 Sep 88 gbr
  Ver 3.25 Added longint to/from packed string[4]         02 Sep 88 gbr
  Ver 3.26 Added sys_time global variable                 07 Sep 88 gbr
  Ver 3.30 Recompiled with Turbo Pascal Version 5.0       29 Sep 88 gbr
  Ver 3.40 Added Month Name (string)                      05 Oct 88 gbr
  Ver 3.50 Changed to use actual scan codes               30 Oct 88 gbr
  Ver 3.60 Added RW word, byte                            18 Nov 88 gbr
  Ver 3.70 Moved many routines to tp5misc.tpu             10 Dec 88 gbr
  Ver 3.80 Added Vtp5wio function                         24 Mar 89 gbr
  Ver 3.90 Added mk_dt_sts() date without century         28 Mar 89 gbr
  Ver 4.00 Added color definitions to windows             06 Jul 89 gbr
  Ver 4.10 Added openwind to open window with default col.07 Jul 89 gbr
  --------------------------------------------------------------------- }

interface

uses
   crt,dos,tp5misc;

const
   fdslen     = 29 ;  { length of fulldatestring }

type
   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' }

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

   intst     = string[2];        { packed string of an integer }
   lintst    = string[4];        { packed string of an longint }

var
   sys_date      :longint;
   null_date     :longint;
   null_date_str : datestring;
   sys_time      :string[8];  { storage for the system time }

   fld, scrn     : integer ; { For field & screen cursor control }
   macro         :array[1..10] of string; { Function key macro storage }
   inv_flag      :boolean;  { if true all write routines inverse the screen,
                              set to false by initialization. User uses
                              this flag to control the screen attributes.}
   col_inv_flag  :boolean;  { true if color monitor, false if monochrome,
                              set by initialization routine,  User may change. }
   inv_color     :byte;     { color to use for inverse data if col_inv_flag
                              is true. Defaults to green, but user may change. }
   in_window     :boolean;  { if true then we are in a window, used by the
                              screen writing routines to high light screen
                              data.  NOTE high lighting can only be done when
                              in_window flag is true. }
   reserv_wind   :integer;  { number of windows to reserve (not close) with
                              endwindows procedure.  Initialized to 0, use
                              with multiple program files. }
   text_fg,                 { Text foreground color }
   text_bg,                 { Text background color }
   framefgnd,              { window border color }
   framebkgnd,             { window background color }
   title_color,             { window title color }
   err_fg,                  { error message foreground }
   err_bg,                  { error message background }
   msg_fg,                  { message foreground }
   msg_bg                   { message background }
                :byte;

PROCEDURE CLRLINE (col,row : integer);
PROCEDURE BEEP ;
PROCEDURE DO_FLD_CTL (key : integer);
         { Adjusts global FLD based on value of key, the ordinal value
           of last key pressed }
PROCEDURE DO_SCRN_CTL ;
         { Checks value of FLD and adjusts value of SCRN accordingly }
PROCEDURE WRITE_STR (st:string ; col,row:integer);
PROCEDURE WRITE_TEMP(var ln:string;tmp:string;x,y:integer);
         { writes a string using a template.  the string (ln) is printed
           left justified in the template using the filler locations.
           quits when the template is complete on the screen.  Fills unused
           template filler locations with space. }
PROCEDURE WRITE_INT (i:integer ; width,col,row:integer);
PROCEDURE WRITE_WORD(i:word; width,col,row:integer);
PROCEDURE WRITE_BYTE(i:byte;width,col,row:integer);
PROCEDURE WRITE_LINT(lint:longint;width,col,row:integer);
PROCEDURE SET_BOOL (var bool : boolean);
         { Sets boolean to be undefined, neither true nor false.
           Boolean is stored as one byte:
               $80 = undefined
               $01 = true
               $00 = false.
           Note : Turbo interprets $80 as true because it is greater than zero! }
FUNCTION DEFINED (bool : boolean) : boolean ;
         { Determines whether the boolean is defined or not }
PROCEDURE WRITE_BOOL (bool:boolean ; col, row:integer);
PROCEDURE WRITE_REAL (r:real ; width,frac,col,row:integer);
FUNCTION BUILD_STR (ch : char ; n : integer) : string ;
         { returns a string of length n of the character ch }
PROCEDURE READ_STR (var st:string ; maxlen, col, row:integer);
         { Read String.  This procedure gets input from the keyboard one
           character at a time and edits on the fly, rejecting invalid
           characters.  COL and ROW tell where to begin the data input
           field, and MAXLEN is the maximum length of the string to be
           returned.
           Only use the Function keys for string input data, for other
           types of input will beep. }
PROCEDURE READ_TEMP(var st:string;tmp:string;col, row:integer);
           { Read string with a template.  This procedure gets input from
           the keyboard one character at a time and edits on the fly,
           rejecting invalid characters.  tmp is a template which is filled
           in where filler characters exist, any other characters are displayed
           on the screen.  Returned string does NOT have the template imbeded in
           it.  COL and ROW tell where to begin the data input
           field, Max length of the string is the max length of the template.
           }
PROCEDURE READ_INT (var int:integer ; maxlen, col, row:integer);
         { Read Integer.  This procedure gets input from the keyboard
           one character at a time and edits on the fly, rejecting
           invalid characters.  COL and ROW tell where to begin the data
           input field, and MAXLEN is the maximum length of the integer
           to be returned. }
PROCEDURE READ_LINT (var lint:longint ; maxlen, col, row:integer);
         { Read LongInt.  This procedure gets input from the keyboard
           one character at a time and edits on the fly, rejecting
           invalid characters.  COL and ROW tell where to begin the data
           input field, and MAXLEN is the maximum length of the integer
           to be returned. }
PROCEDURE READ_WORD(var wd:word; maxlen,col,row:integer);
         { Read Word.  This procedure gets input from the keyboard
           one character at a time and edits on the fly, rejecting
           invalid characters.  COL and ROW tell where to begin the data
           input field, and MAXLEN is the maximum length of the word
           to be returned. }
PROCEDURE READ_BYTE(var bt:byte; maxlen,col,row:integer);
         { Read byte.  This procedure gets input from the keyboard
           one character at a time and edits on the fly, rejecting
           invalid characters.  COL and ROW tell where to begin the data
           input field, and MAXLEN is the maximum length of the byte
           to be returned. }

FUNCTION EQUAL (r1,r2 : real) : boolean ;
         { tests functional equality of two real numbers -- 4/30/85 }
FUNCTION GREATER (r1,r2 : real) : boolean ;
         { tests functional inequality of two real numbers -- 5/1/85 }
PROCEDURE READ_REAL (var r:real ; maxlen,frac,col,row:integer);
         { Read Real.  This procedure gets input from the keyboard
           one character at a time and edits on the fly, rejecting
           invalid characters.  COL and ROW tell where to begin the data
           input field; MAXLEN is the maximum length of the string
           representation of the real number, including sign and decimal
           point; FRAC is the fractional part, the number of digits to
           right of the decimal point.

           Note -- In Turbo the maximum number of significant digits in
           decimal (not scientific) representation is 11.  In TurboBCD,
           the maximum number of significant digits is 18.  It is the
           programmer's responsibility to limit input and computed output
           to the maximum significant digits. }
PROCEDURE READ_YN (var bool:boolean; col,row:integer);
         { Inputs "Y" OR "N" to boolean at column and row specified,
           prints "YES" or "NO."
           Note -- use this when the screen control will not return
           to the question and the boolean IS NOT defined before the
           user answers the question.  Does not affect global FLD. }
PROCEDURE READ_BOOL (var bool:boolean; col,row:integer);
         { Displays boolean at column and row specified, inputs "Y"
           or "N" to set new value of boolean, prints "YES" or "NO."
           Boolean is "forced;" user cannot cursor forward past undefined
           boolean.  Pressing "Y" or "N" terminates entry.
           Boolean is stored as one byte:
               $80 = undefined
               $01 = true
               $00 = false.
           Note : Turbo interprets $80 as true because it is greater
           than zero! }
PROCEDURE PAUSE ;
         {Prints message on bottom line, waits for user response.
          Changed from line 24 to line 23 for windows  gbr}
PROCEDURE HARD_PAUSE ;
         { Like Pause, but only accepts space bar or Escape and only
           goes forward. Changed from line 24 to line 23 for windows.  gbr }
PROCEDURE SHOW_MSG (msg : string);
         { Beeps, displays message centered on line 22, pauses }
         { changed from line 23 to line 22 for windows. gbr }
FUNCTION MK_DT_ST (dt :longint) : datestring ;
         { Makes a string out of a date -- used for printing dates,
           includes century (ie MM/DD/YYYY) }
FUNCTION MK_DT_STS(dt :longint) : datestring ;
         { Makes a string out of a date -- used for printing dates,
           does not include century (ie MM/DD/YY) }
PROCEDURE WRITE_DATE (dt: longint ; 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 }
PROCEDURE READ_DATE (var dt: longint ; 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 : longint) : integer ;
         { Compares two dates, returns 0 if both equal, 1 if first is
           greater, 2 if second is greater. }
PROCEDURE GREG_TO_JUL (dt : longint ; var jdt : juldate);
         { converts a gregorian date to a julian date }
PROCEDURE JUL_TO_GREG (jdt : juldate ; var dt : longint);
         { converts a julian date to a gregorian date }
PROCEDURE NEXT_DAY (var dt : longint);
         { Adds one day to the date }
PROCEDURE PREV_DAY (var dt : longint);
         { Subtracts one day from the date }
FUNCTION DATE_DIFF (dt1, dt2 : longint) : longint ;
         { computes the number of days between two dates }
FUNCTION MONTH_DIFF (dt1, dt2 : longint ) : integer ;
         { Computes number of months between two dates, rounded.
           30.4167 = 356/12, average number of days in a month. }
FUNCTION EQUAL_DATE (dt1, dt2 : longint) : boolean ;
         { Tests whether two dates are equal }
FUNCTION BUILD_FULL_DATE_STR (dt : longint) : fulldatestring ;
         { Build printable string of current date -- from ROS 3.4
           source code. }
FUNCTION MONTH(dt:longint):integer;
         { returns the month portion of a date.}
FUNCTION DAY(dt:longint):integer;
         { returns the day from the date }
FUNCTION YEAR(dt:longint;centry:boolean):integer;
         { returns the year of a date.  if the centry flag is true
           returns 4 digit year otherwise returns two digit year. }
FUNCTION MONTH_NAME(mon:integer):string;
         { returns the month name given the month number (1-12) }

{ ---- window procedures Derived from article in Computer Language
  Magazine June 1988 by James Kerr ---- }
PROCEDURE OPENWIND(wtitle:string;x1,y1,x2,y2:byte);
         { Works just like openwindow except uses the default colors
           for text foreground and background.  Actually just calls
           openwindow with text_fg and text_bg
         }
PROCEDURE OPENWINDOW(wtitle:string;x1,y1,x2,y2:byte;
                     fgnd,bkgnd: byte);
         { wtitle is centered on the top border line of the window, x
         and y are the window coordinates, fgnd and bkgnd are the
         colors of the inside of the window (note the border is always
         white, if a window can not be opened, a message as to why will
         be displayed and the program exits
         }
PROCEDURE CLOSEWINDOW;
         { closes the current open window, does nothing if no
           window to close. }
PROCEDURE ENDWINDOWS;
         { close any open windows when exiting the windows system.  Use
           as the last statment in program to insure return to
           enviroment you came from.  The global reserv_wind is normally
           set to 0 allowing all windows to be closed, if using a
           multi file window program, reserv_wind can be set to the
           number of windows to be left open when a particular program
           terminates.  Always set reserv_wind to 0 before the final
           program call to endwindows.
         }

FUNCTION VTP5WIO:string;
        { Return a string which contains the version of this set of
          routines }
{ ---------------------------------------------------------------- }

implementation
{$I TP5WIO.INC}

procedure read_yn(var bool:boolean; col,row:integer);
{ Inputs "Y" OR "N" to boolean at column and row specified,
  prints "YES" or "NO."

  Note -- use this when the screen control will not return
  to the question and the boolean IS NOT defined before the
  user answers the question.  Does not affect global FLD. }

var ch:char ;
begin
   gotoxy (col,row);
   write ('   ');
   gotoxy (col,row);
   repeat
      keyin (ch)
   until (ch in ['Y', 'y', 'N', 'n']);
   if (ch = 'Y') or (ch = 'y') then
      begin
      write_str('YES',col,row);
      bool := true
   end
   else
      begin
      write_str('NO ',col,row);
      bool := false
   end
end ; { proc read_yn }

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

procedure read_bool(var bool:boolean; col,row:integer);
{ Displays boolean at column and row specified, inputs "Y"
  or "N" to set new value of boolean, prints "YES" or "NO."
  Boolean is "forced;" user cannot cursor forward past undefined
  boolean.  Pressing "Y" or "N" terminates entry.

  Boolean is stored as one byte:
      $80 = undefined
      $01 = true
      $00 = false.
  Note : Turbo interprets $80 as true because it is greater than zero! }

var
   ch  : char ;
   key : integer ;

begin
   write_bool (bool, col, row);
   gotoxy (col, row);
   repeat
      keyin (ch);
      key := ord(ch);
      if key in [$59,$79] then          { 'Y','y' }
         begin
         bool := true ;
         key  := next_fld ;
         do_fld_ctl(key)
      end
      else if key in [$4E, $6E] then    { 'N','n' }
         begin
         bool := false ;
         key  := next_fld ;
         do_fld_ctl(key)
      end
      else if key in terminating then
         begin
         if(not defined(bool)) and
           (key in [carr_rtn, next_fld, next_page]) then
            key := $00
         else
            do_fld_ctl (key)
      end
   until key in terminating ;
   write_bool (bool, col, row)
end ; {--- of read_bool ---}

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

procedure pause ;
{Prints message on bottom line, waits for user response.
 Moved message into window in lower left corner gbr}
var
   ch   : char ;
   key : integer ;
begin
   save_colors;
   openwindow('',2,23,60,25,msg_fg,msg_bg);
   write_str ('SPACE BAR = CONTINUE, UP-ARROW = GO BACK, ESC = QUIT',2,1);
   repeat
      keyin (ch);
      key := ord(ch);
      case key of
         $20      : fld := succ(fld);
         prev_fld : fld := pred(fld);
         prev_page : fld := -999 ;
         escape   : fld := maxint ;
      end ;
   until key in [$20, prev_fld, prev_page, escape] ;
   closewindow;
   restore_colors;
end ; { proc pause }

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

procedure hard_pause ;
{ Like Pause, but only accepts space bar or Escape and only goes forward }
{ puts the message in a window at bottom of screen }
var
   ch   : char ;
   key : integer ;
begin
   save_colors;
   openwindow('',1,23,25,25,msg_fg,msg_bg);
   write_str('SPACE BAR TO CONTINUE',2,1);
   repeat
      keyin (ch);
      key := ord(ch);
      case key of
         $20      : fld := succ(fld);
         escape   : fld := maxint ;
      end ;
   until key in [$20, escape] ;
   closewindow;
   restore_colors;
end ; { proc hard_pause }

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

procedure show_msg(msg : string);
{ Beeps, displays message centered on line 22, pauses }
{ changed to put message in window in lower right corner. gbr }

var
   savefld : integer ;

begin
   save_colors;
   savefld := fld ;
   beep ;
   openwindow('ERROR MESSAGE',26,23,79,25,err_fg,err_bg);
   if length(msg) > 76 then msg := copy(msg,1,52);
   write_str(msg,((52-length(msg)) div 2),1);
   hard_pause ;
   closewindow;
   fld := savefld ;
   restore_colors;
end ; { proc show_msg }

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

{ -- End of Standard screen routines - Beginning of Date routines -- }

function mk_dt_st(dt:longint):datestring;
{ returns a string of the dates to print, returns long date. ie MM/DD/YYYY }

var
   yr,mo,dy,i   :integer;
   result       :longint;
   stmo,stdy    :string[2];
   styr         :string[4];

begin
   if dt = 0 then mk_dt_st := null_date_str
   else
      begin
      dy := (dt mod 100);
      result := (dt - dy); { subtract the number of days }
      result := result div 100;  { move to right }
      mo := (result mod 100);  { get the month }
      yr := (result div 100); { get year }
      str(yr:1,styr);
      str(mo:1,stmo);
      if length(stmo) = 1 then stmo := concat('0',stmo);
      str(dy:1,stdy);
      if length(stdy) = 1 then stdy := concat('0',stdy);
      mk_dt_st := concat(stmo,'/',stdy,'/',styr);
   end;
end; {function mk_dt_st}

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

function mk_dt_sts(dt:longint):datestring;
{ returns a string of the dates to print, returns short date,
  ie MM/DD/YY }

var
   yr,mo,dy,i   :integer;
   result       :longint;
   stmo,stdy    :string[2];
   styr         :string[4];

begin
   if dt = 0 then mk_dt_sts := copy(null_date_str,1,8)
   else
      begin
      dy := (dt mod 100);
      result := (dt - dy); { subtract the number of days }
      result := result div 100;  { move to right }
      mo := (result mod 100);  { get the month }
      yr := (result div 100); { get year }
      str(yr:1,styr);
      if(length(styr) < 2) then styr := concat('??',styr);
      styr := copy(styr,length(styr)-1,2);
      str(mo:1,stmo);
      if length(stmo) = 1 then stmo := concat('0',stmo);
      str(dy:1,stdy);
      if length(stdy) = 1 then stdy := concat('0',stdy);
      mk_dt_sts := concat(stmo,'/',stdy,'/',styr);
   end;
end; {function mk_dt_sts}

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

procedure write_date(dt: longint ; 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 ;

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

procedure get_dt_val(tpdate:longint;var yr,mo,dy:integer);
{ breaks the tpdate into the global integer values }

var
   result       :longint;

begin
   dy := (tpdate mod 100);
   result := (tpdate - dy); { subtract the number of days }
   result := result div 100;  { move to right }
   mo := (result mod 100);  { get the month }
   yr := (result div 100); { get year }
end;  {function get_dt_val}

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

function valid_date (dt:longint) : boolean ;
{ Test whether date is valid }
var
    bad_fld  :integer ;
    yr,mo,dy :integer;

begin
   get_dt_val(dt,yr,mo,dy);   { puts the date in local variables }
   bad_fld := 0 ;
   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;
   valid_date := (bad_fld = 0)
end ; { function valid_date }

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

procedure read_date(var dt: longint ; 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 ;
   savefld,
   bad_fld,
   key,
   p        : integer ;
   yr,mo,dy :integer;
   s,
   template : datestring ;

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

   procedure add_to_str ;
   var
      l : integer ;
   begin
      l := length(s);
      if l = 10 then
         beep
      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 := '' ;
                     gotoxy(col,row);
                     write(template);
                     gotoxy (col,row)
                  end ;
         del_left,
        prev_char,
        BS       :begin   { prev_char is destructive backspace! }
                     l := length(s);
                     if l = 0 then
                        beep
                     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 -- longint }
   var
      code     :integer ;
      result   :longint;
      i        :byte;

   begin
      for i := 1 to 8 do  { fill to 2 digits of year }
         begin
         if length(s) < i then s := concat(s,'0');
         if s[i] = ' ' then s[i] := '0'; { fill any spaces with 0 }
      end;
      val (copy(s,1,2),mo,code);
      if code <> 0 then
         begin
         write ('** MONTH CONVERSION ERROR ',code);
         halt
      end ;
      val (copy(s,4,2),dy,code);
      if code <> 0 then
         begin
         write ('** DAY CONVERSION ERROR ',code);
         halt
      end ;
      val (copy(s,7,4),yr,code);
      if code <> 0 then
         begin
         write ('** YEAR CONVERSION ERROR ',code);
         halt
      end ;
      if ((yr = 0) and (mo = 0) and (dy = 0)) then
         begin                      { default to nodate }
         dt := 0;
      end
      else
         begin                       { plug century }
         if yr < 80 then
            yr := 2000 + yr
         else if yr < 100 then
            yr := 1900 + yr;
         result := yr;
         result := (result * 100) + mo;
         result := (result * 100) + dy;
         dt := result;
      end;
      result := yr;
      result := (result * 100) + mo;
      result := (result * 100) + dy;
      dt := result;
   end ; { proc convert_date}

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

   procedure edit_date ;                  { Edit for valid date }
   begin
      bad_fld := 0 ;
      if (yr = 0) and (mo = 0) and (dy = 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 ; { proc edit_date }

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

begin { proc read_date }
   savefld := fld ;
   ch := chr(filler);
   template := concat(ch,ch,'/',ch,ch,'/',ch,ch,ch,ch);
   if (dt = 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 ;
   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 ;  { uses local yr, mo, and dy }
         edit_date ;
         do_fld_ctl (key);
         if (fld < maxint) and (fld > savefld) then
            begin                          { edit only going forward }
            if bad_fld <> 0 then
               begin
               case bad_fld of
                  1 : show_msg ('INVALID MONTH');
                  2 : show_msg ('INVALID DAY');
                  3 : show_msg ('INVALID YEAR')
               end ; { case }
               fld := savefld
            end
         end
      end
(*      else
          beep  *)
   until key in terminating ;
   write_date (dt,col,row)
end ; { proc read_date }

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

function greater_date(dt1, dt2 : longint) : integer;
{ Compares two dates, returns 0 if both equal, 1 if first is
  greater, 2 if second is greater.
}

begin
   if dt1 > dt2 then
      greater_date := 1
   else if dt2 > dt1 then
      greater_date := 2
   else { both equal }
      greater_date := 0
end ; { --- of greater_date --- }

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

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

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

procedure jul_to_greg(jdt : juldate ; var dt : longint);
{ converts a julian date to a gregorian date }
var
   i, workday :integer ;
   yr,mo,dy   :integer;
begin
   yr := jdt.yr ;
   if (jdt.yr = 0) and (jdt.day = 0) then
      begin
      mo := 0 ; 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 ;
      mo := i ;
      dy := workday - monthtotal[i] ;
      if leapyear(jdt.yr) and (jdt.day = 60) then
         dy := dy + 1
      end;
   { need to convert the globals back to longint }
   dt := yr;
   dt := (dt * 100) + mo;
   dt := (dt * 100) + dy;
end ;  { --- procedure jul_to_greg --- }

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

procedure next_day(var dt : longint);
{ Adds one day to the date }
var
   jdt  : juldate ;
   leap : boolean ;
   yr,mo,dy :integer;

begin
   get_dt_val(dt,yr,mo,dy);
   greg_to_jul (dt,jdt);
   jdt.day := jdt.day + 1 ;
   leap := leapyear (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 : longint);
{ 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 : longint) : longint;
{ computes the number of days between two dates }

var
   jdt1, jdt2 : juldate ;
   i, num_leap_yrs,
   yr1,mo1,dy1,
   yr2,mo2,dy2  : integer ;

begin
   greg_to_jul (dt1, jdt1);
   greg_to_jul (dt2, jdt2);
   get_dt_val(dt1,yr1,mo1,dy1);
   get_dt_val(dt2,yr2,mo2,dy2);
   num_leap_yrs := 0 ;         { adjust for leap years }
   if yr2 > yr1 then
      begin
      for i := yr1 to yr2 - 1 do
         if leapyear(i) then
            num_leap_yrs := num_leap_yrs + 1
   end
   else
      if yr1 > yr2 then
         begin
         for i := yr2 to yr1 - 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) + num_leap_yrs;
end ;

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

function month_diff(dt1, dt2 : longint ) : 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 : longint) : boolean;
{ Tests whether two dates are equal }
begin
   if (dt1 = dt2) then
      equal_date := true
   else
      equal_date := false;
end ;

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

function zeller (dt : longint) : integer ;
{ Compute the day of the week using Zeller's Congruence.
  From ROS 3.4 source code }
var
   century: integer ;
   yr,mo,dy :integer;

begin
   get_dt_val(dt,yr,mo,dy);
   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 ;  { function zeller }

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

function build_full_date_str(dt : longint) : 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 ;
   yr,mo,dy :integer;

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

begin { build_full_date_str }
   get_dt_val(dt,yr,mo,dy);
   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);
   build_full_date_str := s
end ; { function build_full_date_str }

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

procedure get_date;
{ puts the system date in the sys_date date variable. }
var
   year,month,day,dow :word;
begin
   getdate(year,month,day,dow);
   sys_date := year;
   sys_date := (sys_date * 100) + month;
   sys_date := (sys_date * 100) + day;
end; { procedure get_date }

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

procedure get_time;  { gets the system time }
var
  i              : integer;
  hour, minute,
  second, sec100 : word;
  timest         :string;
  hr,mn,sc       :string[2];
begin
  gettime(hour,minute,second,sec100);
  str(hour:2,hr);
  str(minute:2,mn);
  str(second:2,sc);
  timest := hr + ':' + mn + ':' + sc;
  for i := 1 to length(timest) do if timest[i] = ' ' then timest[i] := '0';
  sys_time := timest;
end;    { function get_time }

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

function month(dt:longint):integer;
{ returns the month portion of a date.}
var
   lo_date :integer;
begin
   lo_date := dt mod 10000;
   month := (lo_date div 100);
end; {function month }

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

function day(dt:longint):integer;
{ returns the day from the date }
var
   lo_date :integer;
begin
   lo_date := dt mod 10000;
   day := lo_date mod 100;
end;  { function day }

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

function year(dt:longint;centry:boolean):integer;
{ returns the year of a date.  if the centry flag is true
  returns 4 digit year otherwise returns two digit year. }
var
   hi_date,
   result  :integer;
begin
   hi_date := dt div 10000;
   if(centry) then year := hi_date
   else year := hi_date mod 100;
end; {function year}

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

function month_name(mon:integer):string;
{ returns the month name from the month number }
const
   month: array [1..12] of string[9] =
              ('January','February','March','April','May','June','July',
               'August','September','October','November','December');
begin
   if(mon < 1) or (mon > 12) then
      month_name := 'Unknown'
   else
      month_name := month[mon];
end; {function month_name}

{ ----- End of Date routines ------}

function vtp5wio:string;
{ returns a string containing the version number of this package }
begin
   vtp5wio := vno;
end; {function vtp5wio}

{ ----- Start of initialization ----- }

begin  {unit initialization}
   null_date := 0;
   null_date_str := 'MM/DD/YYYY' ;
   get_date;   { put todays date in sys_date }
   get_time;   { put the time in sys_time }
   { use the vidstart here before it is set to the proper value }
   for vidstart := 1 to 10 do macro[vidstart] := '';  { blank the macro strings }
   inv_flag := false;  { default to normal screen writes }
   inv_color := green; { default color for high lighted items if color monitor}
   numwindows := 0;
   reserv_wind := 0;
   regs.ah := 15;  { prepare for dos interrupt }
   intr($10,regs); { determine current video mode }
   case regs.al of
      0..3 :begin
               vidstart := $B800;  { start of color video memory }
               col_inv_flag := true;
               text_fg     := lightgray;
               text_bg     := black;
               framefgnd   := black;   {yellow;}
               framebkgnd  := black;
               title_color := black;
               err_fg      := red;
               err_bg      := green;
               msg_fg      := blue;
               msg_bg      := lightgray;
            end;
         7 :begin
               vidstart := $B000;  { start of mono video memory }
               col_inv_flag := false;
               text_fg     := lightgray;
               text_bg     := black;
               framefgnd   := lightgray;
               framebkgnd  := black;
               title_color := white;
               err_fg      := lightgray;
               err_bg      := black;
               msg_fg      := lightgray;
               msg_bg      := black;
            end;
      else vidstart := $B000;      { unknown try mono video ?? }
   end; {case}
   in_window := false; { default to not in windows }
end.  { tp5wio unit }