home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
CP/M
/
CPM_CDROM.iso
/
mbug
/
mbug171.arc
/
TURBO-IO.LBR
/
DATE20.IZC
/
DATE20.INC
Wrap
Text File
|
1979-12-31
|
13KB
|
392 lines
{ DATE20.INC -- Routines to write, read and compare dates, etc.
Version 2.0 includes type declarations in this module and allows
entry of a null date (00/00/0000). WPM -- 1/19/86 .
Cosmetic improvement -- 4/16/86 }
type
date = record
yr : integer ; { 0 .. 9999 }
mo : integer ; { 1 .. 12 }
dy : integer ; { 1 .. 31 }
end ;
datestring = string[10] ; { 'MM/DD/YYYY' }
juldate = record
yr : integer ; { 0 .. 9999 }
day : integer ; { 1 .. 366 }
end ;
juldatestring = string[8] ; { 'YYYY/DDD' }
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 }
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 }
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
savefld, bad_fld : integer ;
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
begin
mo := 0 ;
bad_fld := 1
end
else if (dy > 31)
or (dy < 1)
or ((mo in [4,6,9,11]) and (dy > 30)) then
begin
dy := 0 ;
bad_fld := 2
end
else if mo = 2 then
begin
if (leapyear(yr) and (dy > 29))
or ((not leapyear(yr)) and (dy > 28)) then
begin
dy := 0 ;
bad_fld := 2
end
end
else if yr = 0 then
bad_fld := 3
end { with dt do }
end ; { --- of edit_date --- }
begin { read_date }
savefld := fld ; { Save FLD for rest of screen }
fld := 1 ; { Set up FLD for use locally }
write_date (dt, col, row) ;
with dt do
repeat
repeat
case fld of
1 : read_int (mo, 2, col, row) ;
2 : read_int (dy, 2, col+3, row) ;
3 : begin
read_int (yr, 4, col+6, row) ;
if (yr < 0) then
begin
yr := 0 ;
if (fld > 3) and (fld < maxint) then
fld := 3
end
else if not((yr = 0) and (mo = 0) and (dy = 0)) then
begin
if yr < 80 then { Plug century }
yr := 2000 + yr
else if yr < 100 then
yr := 1900 + yr
end ;
write_int (yr, 4, col+6, row)
end ; { 3 }
end ; { CASE }
until (fld < 1) or (fld > 3) ;
if (fld > 3) and (fld < maxint) then { edit only }
begin { going forward }
edit_date ;
if not (bad_fld = 0) then { Date is bad }
begin
beep ;
fld := bad_fld
end
end
until (fld < 1) or (fld > 3) ;
write_date (dt,col,row) ;
if fld = 0 then { Restore FLD for rest of screen }
fld := savefld - 1
else if fld = 4 then
fld := savefld + 1
end ; {--- of 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 ;
{ ----- EOF DATE20.INC --------------------------------------- }
rs + 1
end
else if dt1.yr > d