EXTERNAL progname::date;

EXTERNAL progname::date;

{ This is a complete collection of the various date routines,
set up for separate compilation under Pascal/Z, ver 3.2 or
later.

DATE.LIB contains the necessary subprogram calls for inclusion
in the main program.

Note that <progname> has to be substituted with the name of the
main program to be separately compiled.

The following global declarations must be made in the main
program:
TYPE string0 = string 0;
string255 = string 255;
byte = 0..255;
PROCEDURE setlength;
FUNCTION length;
}

PROCEDURE prompt (msg : string255);

CONST msglength = 12; { should be longer than longest message }
leader = '.'; { could be a space if desire }
endprompt = ' => ';

VAR count : integer;
esc : char;

begin
append (msg,' ');
if length(msg) < msglength then
for count := succ(length(msg)) to msglength do
append (msg,leader);
write (msg,endprompt)
end;

PROCEDURE getdate (msg : string255; VAR mo, da, yr : byte);

CONST yrspan = 89;
yrbase = 10;

VAR ch : char;
good : boolean;
temp : integer;

begin
repeat
good := true;
prompt (msg);
readln (mo,ch,da,ch,temp);
temp := temp mod 100 - yrbase;
if (da < 1) or (da > 31) or (mo < 1) or (mo >12)
or (temp < 0) or (temp > yrspan) then
begin
good := false;
writeln (' *** Bad date ***')
end
until good;
yr := temp
end;

FUNCTION makedate (msg : string255) : integer;

CONST yrbase = 10;

VAR days : integer;
da, mo, yr : byte;
str : string255;

begin
getdate (msg,mo,da,yr);
case mo of
1 : days := 0;
2 : days := 31;
3 : days := 59;
4 : days := 90;
5 : days := 120;
6 : days := 151;
7 : days := 181;
8 : days := 212;
9 : days := 243;
10 : days := 273;
11 : days := 304;
12 : days := 334;
end;
days := days + (yr*365) + (yr div 4) + da;
if ((yr + yrbase) mod 4 = 0) and (mo > 2) then days := days + 1;
makedate := days
end;

PROCEDURE rgetdate (msg : string255; minyr, maxyr : byte;
VAR mo, da, yr : byte);

CONST yrspan = 89;
yrbase = 10;

VAR ch : char;
good : boolean;
temp : integer;

begin
repeat
good := true;
prompt (msg);
readln (mo,ch,da,ch,temp);
temp := temp mod 100;
if (da < 1) or (da > 31) or (mo < 1) or (mo >12)
or (temp < minyr) or (temp > maxyr) then
begin
good := false;
writeln (' *** Bad date ***')
end
until good;
yr := temp - yrbase
end;

FUNCTION rmakedate (msg : string255; minyr, maxyr : byte) : integer;

CONST yrbase = 10;

VAR days : integer;
da, mo, yr : byte;
str : string255;

begin
rgetdate (msg,minyr,maxyr,mo,da,yr);
case mo of
1 : days := 0;
2 : days := 31;
3 : days := 59;
4 : days := 90;
5 : days := 120;
6 : days := 151;
7 : days := 181;
8 : days := 212;
9 : days := 243;
10 : days := 273;
11 : days := 304;
12 : days := 334;
end;
days := days + (yr*365) + (yr div 4) + da;
if ((yr + yrbase) mod 4 = 0) and (mo > 2) then days := days + 1;
rmakedate := days
end;

PROCEDURE brkdate (days : integer; VAR mo, da, yr, weekday : byte);

CONST yrbase = 10;
yrfix = yrbase - 1;

VAR data, temp, adjust, yradj : integer;

begin
adjust := 1 + yrfix mod 4 + (((yrfix mod 28) div 4) * 5);
yradj := (yrbase mod 4) * 365;
weekday := (days + adjust) mod 7;
data := trunc((days + yradj) / 365.25) - yrbase mod 4;
yr := data + yrbase;
temp := days - (365 * data) - (data + yrfix mod 4) div 4;
mo := 0;
data := 0;
repeat
if (data < temp) then
begin
mo := mo + 1;
temp := temp - data
end;
case mo of
1,3,5,7,8,10,12 : data := 31;
4,6,9,11 : data := 30;
2 : if (yr mod 4 = 0) then data := 29
else data := 28
end
until (data >= temp) or (mo = 12);
da := temp
end;

FUNCTION dastrlong (days : integer; withday : boolean) : string255;

CONST zero = 48;

VAR day, mo, date, yr : byte;
str, str2 : string255;

begin
brkdate (days,mo,date,yr,day);
if withday then
begin
case day of
0 : str := 'Sunday';
********************************************************************************************************************************;
6 : str := 'Saturday'
end;
append (str,', ')
end
else setlength (str,0);
case mo of
1 : str2 := 'January';
2 : str2 := 'February';
3 : str2 := 'March';
4 : str2 := 'April';
5 : str2 := 'May';
6 : str2 := 'June';
7 : str2 := 'July';
8 : str2 := 'August';
9 : str2 := 'September';
10 : str2 := 'October';
11 : str2 := 'November';
12 : str2 := 'December'
end;
append (str,str2);
append (str,' ');
if (date > 9) then append (str,chr((date div 10) + zero));
append (str,chr((date mod 10) + zero));
append (str,', 19');
append (str,chr((yr div 10) + zero));
append (str,chr((yr mod 10) + zero));
dastrlong := str
end;

FUNCTION dastrshort (days : integer; withday : boolean) : string255;

CONST zero = 48;

VAR day, mo, date, yr : byte;
str, str2 : string255;

begin
brkdate (days,mo,date,yr,day);
if withday then
begin
case day of
0 : str := 'Sun';
1 : str := 'Mon';
2 : str := 'Tues';
3 : str := 'Wed';
4 : str := 'Thurs';
5 : str := 'Fri';
6 : str := 'Sat'
end;
append (str,', ')
end
else setlength (str,0);
case mo of
1 : str2 := 'Jan';
2 : str2 := 'Feb';
3 : str2 := 'Mar';
4 : str2 := 'Apr';
5 : str2 := 'May';
6 : str2 := 'June';
7 : str2 := 'July';
8 : str2 := 'Aug';
9 : str2 := 'Sept';
10 : str2 := 'Oct';
11 : str2 := 'Nov';
12 : str2 := 'Dec'
end;
append (str,str2);
append (str,' ');
if (date > 9) then append (str,chr((date div 10) +********************************************************************************************************************************chr((yr mod 10) + zero));
dastrshort := str
end;

FUNCTION strbyte (val : byte; withspace : boolean) : string255;

CONST zero = 48;

VAR ch : char;
str : string255;

begin
setlength (str,0);
if (val div 10 = 0) and withspace
then str := ' '
else str := chr (val div 10 + zero);
append (str,chr(val mod 10 + zero));
strbyte := str
end;

FUNCTION dastrfixed (days : integer; spaces : boolean) : string255;

CONST zero = 48;
separator = '-';

VAR day, mo, da, yr : byte;
str : string255;

begin
brkdate (days,mo,da,yr,day);
setlength (str,0);
append (str,strbyte(mo,spaces));
append (str,separator);
append (str,strbyte(da,spaces));
append (str,separator);
append (str,strbyte(yr,false));
dastrfixed := str
end;