CP/M/CPM_CDROM.iso/simtel/sigm/vols000/vol023/date.pas

Pascal/Delphi Source File | 1984-04-29 | 6.5 KB | 303 lines

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;