Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/math/date.src

Text File | 1988-05-03 | 50.9 KB | 1,914 lines

--::::::::::
--000_read_me.info
--::::::::::
--------------------------------------------------------------------------
--
-- Considerations For Porting date_package Onto Your System:
--
--    1) This Pager file is in correct compilation order and may
--       be given to a compiler as it stands (see number 2 below).
--       The software documentation is in comments.
--
--    2) The generic date_package takes two parameters.
--       The first parameter, short_value, must be at least a 16
--       bit signed value.  The second parameter, long_value,
--       must be at least a 32 bit signed value.
--
--       With our compiler the type short_integer is a 16 bit signed
--       value and integer is a 32 bit signed value.
--
--       To run the demo programs you will modify the instantiations
--       of date_package to use the 16 and 32 bit type names which
--       are supported by your compiler.
--
--------------------------------------------------------------------------
--
-- Software Development Environment:
--
--     Operating System:    VAX/VMS version 4.4
--     Compiler:        DEC Ada version 1.3
--
--    The generic date_package and demo programs have been compiled and
--    run on an IBM PC/AT.  The environment consists of MS/DOS version
--    2.1 and version 1.2 of Alsys Ada.
--
--------------------------------------------------------------------------
--
-- Compilation Order:
--
--    date_package_.ada
--    date_package.ada
--    month_print.ada
--    days_till.ada
--    friday_13th.ada
--    test_ranges.ada
--
--------------------------------------------------------------------------
--
-- File Information:
--
-- File Name        Description
--
-- date_package_.ada    Specification of the generic date_package.
-- date_package.ada    Body of date_package.
-- month_print.ada    Demo to print a month in calendar-like style.
-- days_till.ada    Demo similar to month_print but a lot more fun.
-- friday_13th.ada    Demo to find every Friday the 13th in the year range.
-- test_ranges.ada    Demo to test the error trapping of date arithmetic.
--
--------------------------------------------------------------------------
--::::::::::
--date_package_.ada
--::::::::::

-------- SIMTEL20 Ada Software Repository Prologue ------------
--
-- Unit name    : generic package specification date_package
-- Version      : 1.0
-- Authors      : David G. Gawron
--              : Dr. Mars J. Gralia
--              : The Johns Hopkins University
--              : Applied Physics Laboratory
--              : Johns Hopkins Road
--              : Laurel, Maryland  20707
-- DDN Address  : dgg@aplvax gralia@aplvax
-- Copyright    : (c) 1986 David G. Gawron, Dr. Mars J. Gralia
-- Date created :  October  1986
-- Release date :  November 1986
-- Last update  :  Gawron, October 1986
-- Machine/System Compiled/Run on : DEC VAX 11/750, DEC Ada v1.3
--
---------------------------------------------------------------
--
-- Keywords     :  Calendar, Date, Julian Date
--
-- Abstract     :
--
--  Please refer to the prologue file for a description of the
-- date package.
--
------------------ Revision history ---------------------------
--
-- DATE         VERSION    AUTHOR                  HISTORY
-- 10/86        1.0     Gawron/Gralia           Initial release
--
------------------ Distribution and Copyright -----------------
--
-- This prologue must be included in all copies of this software.
--
-- This software is copyright by the authors.
--
-- This software is released to the Ada community.
-- Restrictions on use or distribution:  NONE
--
------------------ Disclaimer ---------------------------------
--
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered.  The user is advised to
-- test the software thoroughly before relying on it.  The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.
--
-------------------END-PROLOGUE--------------------------------



generic
    type short_value is range <>;   -- at least a 16 bit signed value
    type long_value  is range <>;   -- at least a 32 bit signed value



package date_package is



    -- date_type is the main object dealt with by all of
    -- the routines in this package.
    --
    type date_type is private;



    -- These types constrain the values
    -- used to compose dates.
    --
    -- The lower bound of the year range is set at 1753 to
    -- get around a glitch in the calendar that happened in
    -- September 1752.  The internal routines used for date
    -- calculations don't account for this glitch.  The upper
    -- bound of the year range corresponds to the upper bound
    -- of the year number used in CALERDAR.
    --
    subtype year_number_type  is short_value range 1753..2099;
    subtype month_number_type is short_value range 1..12;
    subtype day_number_type   is short_value range 1..31;
    subtype julian_day_type   is short_value range 1..366;



    -- day_delta_type reflects the number of days from
    -- January 1, year_number_type'first to December 31, year_number_type'last.
    -- The range spans the values possible as a result of the
    -- subtraction operator when applied to two dates.
    --
    subtype day_delta_type is long_value range -126_739..126_739;



    -- day_name_type provides the standard names for the
    -- days of the week.
    --
    type day_name_type is
    (Sunday, Monday, Tuesday, Wednesday, Thursday, Friday, Saturday);




    -- Description:
    --    current_date returns the current date.
    --  Note: that the range of dates returned is dependent upon
    --  the range of the system date.  The current range is todays
    --  date to December 31, year_number_type'last.
    --
    -- Raises:
    --  nothing
    --
    function current_date
    return date_type;



    -- Description:
    --  year returns the year number of the given date.
    --
    -- Raises:
    --  nothing.
    --
    function year (date : in date_type)
    return year_number_type;



    -- Description:
    --  month returns the month number of the given date.
    --
    -- Raises:
    --  nothing.
    --
    function month (date : in date_type)
    return month_number_type;



    -- Description:
    --  day returns the day number of the given date.
    --
    -- Raises:
    --  nothing.
    --
    function day (date : in date_type)
    return day_number_type;



    -- Description:
    --  day_of_year returns the annual Julian day
    --  number of the given date.
    --
    -- Raises:
    --  nothing.
    --
    function day_of_year (date : in date_type)
    return julian_day_type;



    -- Description:
    --  day_name returns the day name of the given date.
    --
    -- Raises:
    --  nothing.
    --
    function day_name (date : in date_type)
    return day_name_type;



    -- Description:
    --  split breaks apart a date into the year, month, day, and
    --  day name components.
    --
    -- Raises:
    --  nothing.
    --
    procedure split (date     : in date_type;
             year     : out year_number_type;
             month    : out month_number_type;
             day      : out day_number_type;
             day_name : out day_name_type);


    -- Description:
    --    split break apart a date into the year and
    --    annual Julian day number components.
    --
    -- Raises:
    --  nothing.
    --
    procedure split (date        : in date_type;
             year        : out year_number_type;
             julian_day  : out julian_day_type);



    -- Description:
    --  date_of takes a year, month, and day then converts
    --  them into a date.
    --
    -- Raises:
    --  date_is_not_valid when the day given is larger than
    --  the maximum number of days in the given month.
    --    For example, February 30 or September 31.
    --
    function date_of (year  : in year_number_type;
              month : in month_number_type;
              day   : in day_number_type)
    return date_type;


    -- Description:
    --  date_of takes a year and annual Julian day number
    --  then converts them into a date.
    --
    -- Raises:
    --  date_is_not_valid when the day number given is
    --  366 for non-leap years.
    --
    function date_of (year        : in year_number_type;
              julian_day  : in julian_day_type)
    return date_type;



    -- Description:
    --  + adds days to a date.  This is one form of + where
    --  the date is on the left side of the operator.
    --
    -- Raises:
    --  result_out_of_range when the resulting date does
    --    not fall in the year range
    --    year_number_type'first to year_number_type'last.
    --
    function "+" (left  : in date_type;
          right : in day_delta_type)
    return date_type;


    -- Description:
    --  + adds days to a date.  This another form of + where
    --  the date is on the right side of the operator.
    --
    -- Raises:
    --  result_out_of_range when the resulting date does
    --    not fall in the year range
    --    year_number_type'first to year_number_type'last.
    --
    function "+" (left  : in day_delta_type;
          right : in date_type)
    return date_type;



    -- Description:
    --  - subtracts days days from a date.  This is one form
    --  of - where the date is on the left side of the operator
    --  and the days are on the right.
    --
    -- Raises:
    --  result_out_of_range when the resulting date does
    --    not fall in the year range
    --    year_number_type'first to year_number_type'last.
    --
    function "-" (left  : in date_type;
          right : in day_delta_type)
    return date_type;


    -- Description:
    --  - subtracts a date from a date.  This is another form
    --  of - where the result is expreseed in days.
    --
    -- Raises:
    --  nothing.
    --
    function "-" (left  : in date_type;
          right : in date_type)
    return day_delta_type;



    -- Description:
    --  The following functions provide logical
    --  operations on dates.
    --
    -- Raises:
    --  exceptions are not raised by any of
    --    these routines.

    function "<" (left, right : in date_type)
    return boolean;

    function "<=" (left, right : in date_type)
    return boolean;



    function ">" (left, right : in date_type)
    return boolean;

    function ">=" (left, right : in date_type)
    return boolean;



    -- Raised when the used gives a date that is not valid.
    -- For example, February 30 for any year would cause this
    -- exception to be raised.
    --
    -- Raised by both versions of the date_of function.
    --
    date_is_not_valid        : exception;


    -- Raised when the result of date arithmetic is not in the
    -- range for dates.  For example, 1/1/1753 minus 2 days
    -- would cause this exception to be raised.
    --
    -- Raised by both versions of "+" and by "-" which handles
    -- date_type and day_delta_type.
    --
    result_out_of_range        : exception;



    private
    type date_type is
        record
        year        : year_number_type;
        month        : month_number_type;
        day        : day_number_type;
        day_name    : day_name_type;
        julian_date : long_value;
        end record;



end date_package;
--::::::::::
--date_package.ada
--::::::::::

-------- SIMTEL20 Ada Software Repository Prologue ------------
--
-- Unit name    : package body date_package
-- Version      : 1.0
-- Authors      : David G. Gawron
--              : Dr. Mars J. Gralia
--              : The Johns Hopkins University
--              : Applied Physics Laboratory
--              : Johns Hopkins Road
--              : Laurel, Maryland  20707
-- DDN Address  : dgg@aplvax gralia@aplvax
-- Copyright    : (c) 1986 David G. Gawron, Dr. Mars J. Gralia
-- Date created :  October  1986
-- Release date :  November 1986
-- Last update  :  Gawron, October 1986
-- Machine/System Compiled/Run on : DEC VAX 11/750, DEC Ada v1.3
--
---------------------------------------------------------------
--
-- Keywords     :  Calendar, Date, Julian Date
--
-- Abstract     :
--
--  Please refer to the prologue file for a description of the
-- date package.
--
------------------ Revision history ---------------------------
--
-- DATE         VERSION    AUTHOR                  HISTORY
-- 10/86        1.0     Gawron/Gralia           Initial release
--
------------------ Distribution and Copyright -----------------
--
-- This prologue must be included in all copies of this software.
--
-- This software is copyright by the authors.
--
-- This software is released to the Ada community.
-- Restrictions on use or distribution:  NONE
--
------------------ Disclaimer ---------------------------------
--
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered.  The user is advised to
-- test the software thoroughly before relying on it.  The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.
--
-------------------END-PROLOGUE--------------------------------



with text_io;
with calendar;


package body date_package is





------------ START OF NON EXPORTED TYPES AND VARIABLES ------------


    -- These types will be used to construct tables that will
    -- hold information about the days of the months.
    --
    subtype day_span_type is short_value range 0..334;

    type month_table_type is
    array(month_number_type) of day_span_type;



    -- days_in_month_table holds a count of the number of days
    -- in each month.  The table is set up for a non-leap year.
    -- In a leap year a local copy of the table is modified to
    -- reflect the 29 days in February.
    --
    days_in_month_table : constant month_table_type :=
    (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);


------------ END OF NON EXPORTED TYPES AND VARIABLES  ------------





------------ START OF NON EXPORTED ROUTINES ------------


    -- Description:
    --  leap_year will return true when the given year is
    --  a leap year.
    --
    -- Raises:
    --  nothing.
    --
    function leap_year (year : in year_number_type)
    return boolean is
    begin
        if ((year mod 4 = 0)    and
           (year mod 100 /= 0)) or
           (year mod 400 = 0)
        then
        return true;
        else
        return false;
        end if;
    end leap_year;



    -- Description:
    --  valid_date will return true if the given day is less-than
    --  or equal-to the number of days in the given month.
    --  days_in_month_table will be modified when a leap year
    --  is encountered.
    --
    -- Raises:
    --  nothing.
    --
    function valid_date (year  : in year_number_type;
             month : in month_number_type;
             day   : in day_number_type)
    return boolean is

    days_in_month        : short_value;

    begin
        days_in_month := days_in_month_table(month);

        if (leap_year (year) and month = 2) then
        days_in_month := 29;
        end if;

        if (day <= days_in_month) then
        return true;
        else
        return false;
        end if;
    end valid_date;



    -- Description:
    --  This version of valid_date will return true if the
    --  given julian day number is less-than or equal-to 365
    --  for a non-leap year.  When a lear year is encountered
    --  true is returned automatically since the range constraint
    --  on julian_day_type will prevent the value from being
    --  greater-than 366.
    --
    -- Raises:
    --  nothing.
    --
    function valid_date (year        : in year_number_type;
             julian_day  : in julian_day_type)
    return boolean is

    begin
        if (leap_year (year)) then
        return true;
        elsif (julian_day <= 365) then
        return true;
        else
        return false;
        end if;
    end valid_date;



    -- Description:
    --  calculate_date will take an internal julian date and
    --  convert it into a date_type.
    --
    --  The code of this function is a modified version of algorithm
    --  199 from the Collected Algorithms of the ACM.
    --  The author of algorithm 199 is Robert G. Tantzen.
    --
    -- Raises:
    --  nothing.
    --
    function calculate_date (julian_date : in long_value)
    return date_type is

    a    : long_value;
    b    : long_value;
    c    : long_value;
    d    : long_value;
    date    : date_type;

    begin
        a := julian_date - 1_721_119;
        b := (4 * a - 1) / 146_097;
        a := 4 * a - 1 - 146_097 * b;
        d := a / 4;
        a := (4 * d + 3) / 1_461;
        d := 4 * d + 3 - 1_461 * a;
        d := (d + 4) / 4;
        c := (5 * d - 3) / 153;
        d := 5 * d - 3 - 153 * c;
        d := (d + 5) / 5;
        b := 100 * b + a;

        if (c < 10) then
        c := c + 3;
        else
        c := c - 9;
        b := b + 1;
        end if;

        date.year        := year_number_type(b);
        date.month       := month_number_type(c);
        date.day         := day_number_type(d);
        date.day_name    := day_name_type'val((julian_date + 1) mod 7);
        date.julian_date := julian_date;

        return date;
    end calculate_date;



    -- Description:
    --  calculate_julian will take a year, month, and day and
    --  convert it into an internal julian date.
    --
    --  The code of this function is a modified version of algorithm
    --  199 from the Collected Algorithms of the ACM.
    --  The author of algorithm 199 is Robert G. Tantzen.
    --
    -- Raises:
    --  nothing.
    --
    function calculate_julian (year  : in year_number_type;
                   month : in month_number_type;
                   day   : in day_number_type)
    return long_value is

    internal_year    : long_value;
    internal_month    : long_value;
    internal_day    : long_value;
    julian_date    : long_value;
    c        : long_value;
    ya        : long_value;

    begin
        internal_year  := long_value(year);
        internal_month := long_value(month);
        internal_day   := long_value(day);

        if (internal_month > 2) then
        internal_month := internal_month - 3;
        else
        internal_month := internal_month + 9;
        internal_year  := internal_year - 1;
        end if;

        c  := internal_year / 100;
        ya := internal_year - (100 * c);
        julian_date := (146_097 * c) / 4 +
               (1_461 * ya) / 4 +
               (153 * internal_month + 2) / 5 +
               internal_day + 1_721_119;

        return julian_date;
    end calculate_julian;


------------ END OF NON EXPORTED ROUTINES ------------





------------ START OF EXPORTED ROUTINES ------------


    function current_date
    return date_type is

    date        : date_type;
    current_time    : calendar.time;

    begin
        -- The range of the dates the will be returned by
        -- this function depend upon the CALENDAR package.
        -- Currently the largest date CALENDAR handles is
        -- December 31 2099.
        --
        current_time := calendar.clock;

        date.year  := year_number_type(calendar.year (current_time));
        date.month := month_number_type(calendar.month (current_time));
        date.day   := day_number_type(calendar.day (current_time));

        date.julian_date :=
        calculate_julian (date.year, date.month, date.day);

        date.day_name := day_name_type'val((date.julian_date + 1) mod 7);

        return date;
    end current_date;



    function year (date : in date_type)
    return year_number_type is
    begin
        return date.year;
    end year;



    function month (date : in date_type)
    return month_number_type is
    begin
        return date.month;
    end month;



    function day (date : in date_type)
    return day_number_type is
    begin
        return date.day;
    end day;



    function day_of_year (date : in date_type)
    return julian_day_type is

    -- day_count_table holds a count, for each month, of the total
    -- number of days in the preceeding months.  For example,
    -- there are 59 days before March in a non-leap year.
    --
    day_count_table : constant month_table_type :=
        (0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334);

    days_since_first_of_year    : julian_day_type;

    begin
        days_since_first_of_year :=
        day_count_table(date.month) + date.day;

        -- When a date in a leap year is given and the date
        -- falls after February the count is adjusted to
        -- account for the extra day in February.
        --
        if (leap_year (date.year) and (date.month > 2)) then
        days_since_first_of_year := days_since_first_of_year + 1;
        end if;

        return days_since_first_of_year;
    end day_of_year;



    function day_name (date : in date_type)
    return day_name_type is
    begin
        return date.day_name;
    end day_name;



    procedure split (date     : in date_type;
             year     : out year_number_type;
             month    : out month_number_type;
             day      : out day_number_type;
             day_name : out day_name_type) is
    begin
        year     := date.year;
        month    := date.month;
        day      := date.day;
        day_name := date.day_name;
    end split;


    procedure split (date       : in date_type;
             year       : out year_number_type;
             julian_day : out julian_day_type) is
    begin
        year       := date.year;
        julian_day := day_of_year (date);
    end split;



    function date_of (year  : in year_number_type;
              month : in month_number_type;
              day   : in day_number_type)
    return date_type is

    date    : date_type;

    begin
        if (valid_date (year, month, day)) then
        date.year  := year;
        date.month := month;
        date.day   := day;

        date.julian_date := calculate_julian (year, month, day);

        date.day_name :=
            day_name_type'val((date.julian_date + 1) mod 7);
        return date;
        else
        raise date_is_not_valid;
        end if;
    end date_of;


    function date_of (year       : in year_number_type;
              julian_day : in julian_day_type)
    return date_type is

    month        : month_number_type;
    date        : date_type;

    day_table   : month_table_type;
    days        : short_value;

    begin
        if (valid_date (year, julian_day)) then

        day_table := days_in_month_table;

        -- When the given date is in a leap year the table
        -- is adjusted to account for the extra day in February.
        --
        if (leap_year (year)) then
            day_table(2) := 29;
        end if;

        -- The months are looped through and the annual
        -- julian day number reduced until it falls into
        -- a month.
        --
        days := julian_day;
        for i in month_number_type loop
            month := i;
            exit when (days - day_table(i)) <= 0;
            days := days - day_table(i);
        end loop;

        date.year  := year;
        date.month := month;
        date.day   := day_number_type(days);

        date.julian_date :=
            calculate_julian (date.year, date.month, date.day);

        date.day_name :=
            day_name_type'val((date.julian_date + 1) mod 7);
        return date;
        else
        raise date_is_not_valid;
        end if;
    end date_of;



    function "+" (left  : in date_type;
          right : in day_delta_type)
    return date_type is
    begin
        return calculate_date (left.julian_date + right);

        -- A constraint error in this case would originate in
        -- calculate_date and indicate that the range constraint
        -- on year_number_type was violated by the result of
        -- left.julian_date + right.
        --
        exception
        when constraint_error =>
            raise result_out_of_range;
    end "+";


    function "+" (left  : in day_delta_type;
          right : in date_type)
    return date_type is
    begin
        return calculate_date (right.julian_date + left);

        -- A constraint error in this case would originate in
        -- calculate_date and indicate that the range constraint
        -- on year_number_type was violated by the result of
        -- right.julian_date + left.
        --
        exception
        when constraint_error =>
            raise result_out_of_range;
    end "+";



    function "-" (left  : in date_type;
          right : in day_delta_type)
    return date_type is
    begin
        return calculate_date (left.julian_date - right);

        -- A constraint error in this case would originate in
        -- calculate_date and indicate that the range constraint
        -- on year_number_type was violated by the result of
        -- left.julian_date - right.
        --
        exception
        when constraint_error =>
            raise result_out_of_range;
    end "-";


    function "-" (left  : in date_type;
          right : in date_type)
    return day_delta_type is
    begin
        return left.julian_date - right.julian_date;
    end "-";



    function "<" (left, right : in date_type)
    return boolean is
    begin
        return (left.julian_date < right.julian_date);
    end "<";


    function "<=" (left, right : in date_type)
    return boolean is
    begin
        return (left.julian_date <= right.julian_date);
    end "<=";



    function ">" (left, right : in date_type)
    return boolean is
    begin
        return (left.julian_date > right.julian_date);
    end ">";


    function ">=" (left, right : in date_type)
    return boolean is
    begin
        return (left.julian_date >= right.julian_date);
    end ">=";


------------ END OF EXPORTED ROUTINES ------------



end date_package;
--::::::::::
--month_print.ada
--::::::::::

-------- SIMTEL20 Ada Software Repository Prologue ------------
--
-- Unit name    : procedure month_print
-- Version      : 1.0
-- Authors      : David G. Gawron
--              : The Johns Hopkins University
--              : Applied Physics Laboratory
--              : Johns Hopkins Road
--              : Laurel, Maryland  20707
-- DDN Address  : dgg@aplvax
-- Copyright    : (c) 1986 David G. Gawron
-- Date created :  October  1986
-- Release date :  November 1986
-- Last update  :  Gawron, October  1986
-- Machine/System Compiled/Run on : DEC VAX 11/750, DEC Ada v1.3
--
---------------------------------------------------------------
--
-- Keywords     :  Demonstration of date_package
--
-- Abstract     :
--
--  This procedure demonstrates the use of several date_package
-- entry points.  The procedure generates a calendar-like listing
-- of a month that includes the annual Julian day number for each
-- day of the month.  Try it for a leap year.
--
------------------ Revision history ---------------------------
--
-- DATE         VERSION    AUTHOR                  HISTORY
-- 10/86        1.0     Gawron                  Initial release
--
------------------ Distribution and Copyright -----------------
--
-- This prologue must be included in all copies of this software.
--
-- This software is copyright by the author.
--
-- This software is released to the Ada community.
-- Restrictions on use or distribution:  NONE
--
------------------ Disclaimer ---------------------------------
--
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered.  The user is advised to
-- test the software thoroughly before relying on it.  The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.
--
-------------------END-PROLOGUE--------------------------------



with text_io;
with date_package;



procedure month_print is


    package date is new date_package(short_value => short_integer,
                     long_value  => integer);


    use text_io;
    use date;


    -- The date package doesn't provide the month names
    -- so this type is used.
    --
    type month_name_type is
    (January, February, March, April, May, June,
     July, August, September, October, November, December);



    -- These will specify the year and month to be printed.
    --
    base_year            : year_number_type;
    base_month            : month_number_type;



    -- These dates will be used to print the month
    -- in calerdar form.
    --
    base_date_1            : date_type;
    base_date_2            : date_type;



    -- These are used in the layout of the values
    -- printed for a month.
    --
    column_setting_1        : positive_count;
    column_setting_2        : positive_count;



    -- This will be used to tell if the user wants to continue
    -- running the demo.
    --
    user_response        : character;



    -- The I/O for each type we deal with.
    --
    package year_io       is new integer_io(year_number_type);
    package month_io      is new integer_io(month_number_type);
    package day_io        is new integer_io(day_number_type);
    package day_name_io   is new enumeration_io(day_name_type);
    package month_name_io is new enumeration_io(month_name_type);
    package julian_day_io is new integer_io(julian_day_type);



    begin

    loop
    new_line (25);
    put_line ("This demo takes one date as input.");
    put_line ("The date given will specify the year and month");
    put_line ("to be printed in a style similar to a calendar.");
    new_line;
    put_line ("The printout will include the annual Julian day");
    put_line ("number for each day of the month.  The annual Julian");
    put_line ("day is a count of the number of days into a year.");
    put_line ("For example, December 31 has an annual Julian day");
    put_line ("number of 365 in non-leap years and 366 in leap years.");
    new_line (2);

    put ("Valid year numbers are within the range ");
    year_io.put (year_number_type'first);
    put (" to ");
    year_io.put (year_number_type'last);
    new_line;
    put ("and valid month numbers are within the range ");
    month_io.put (month_number_type'first);
    put (" to ");
    month_io.put (month_number_type'last);
    put (".");
    new_line (2);


    put ("Please enter the month to be printed out: ");
    month_io.get(base_month);
    new_line;
    put ("and the year: ");
    year_io.get(base_year);

    -- The dates are set up to be the first
    -- of the given month.
    --
    base_date_1 := date_of (base_year, base_month, 1);
    base_date_2 := base_date_1;


    -- The month name and year are printed at
    -- the top.
    --
    new_line (25);
    text_io.set_col (35);
    month_name_io.put (month_name_type'val(base_month - 1));
    year_io.put (base_year);
    text_io.new_line (2);


    -- The weekday names are printed.
    --
    column_setting_1 := 1;
    for day_name in day_name_type loop
        set_col (column_setting_1);
        day_name_io.put (day_name);
        column_setting_1 := column_setting_1 + 12;
    end loop;
    text_io.new_line (2);


    -- An offset into the week is calculated.  The offset
    -- places the start of the month on the correct day.
    --
    column_setting_1 :=
        (day_name_type'pos(day_name (base_date_1)) * 12) + 1;

    column_setting_2 := column_setting_1;


    loop
        -- The days of the month are printed.
        --
        loop
        exit when (base_month /= month (base_date_1));
        set_col (column_setting_1);
        day_io.put (day (base_date_1));
        exit when (day_name (base_date_1) = Saturday) or
              ((base_month = 12) and (day (base_date_1) = 31));
        column_setting_1 := column_setting_1 + 12;
        base_date_1 := base_date_1 + 1;
        end loop;


        -- And the annual Julian day is printed below the
        -- day number.
        --
        loop
        exit when (base_month /= month (base_date_2));
        set_col (column_setting_2);
        text_io.put ("(");
        julian_day_io.put (item  => day_of_year (base_date_2),
                          width => 1);
        text_io.put (")");
        exit when (day_name (base_date_2) = Saturday) or
              ((base_month = 12) and (day (base_date_2) = 31));
        column_setting_2 := column_setting_2 + 12;
        base_date_2 := base_date_2 + 1;
        end loop;


        -- When the month flips over or at the end of the
        -- year we know the printing is done.
        --
        exit when (base_month /= month (base_date_1)) or
              ((base_month = 12) and (day (base_date_1) = 31));

        -- Setup for the next week to be printed.
        --
        text_io.new_line (2);
        column_setting_1 := 1;
        column_setting_2 := 1;
        base_date_1 := base_date_1 + 1;
        base_date_2 := base_date_1;
    end loop;


    new_line (2);
    put ("Enter a Q to quit or any other character to continue: ");
    get (user_response);
    exit when (user_response = 'Q');


    end loop;


    exception
        when data_error =>
        new_line (2);
        put_line ("Input data out of range.  Bye!");

    end month_print;
--::::::::::
--days_till.ada
--::::::::::

-------- SIMTEL20 Ada Software Repository Prologue ------------
--
-- Unit name    : procedure days_till
-- Version      : 1.0
-- Authors      : David G. Gawron
--              : The Johns Hopkins University
--              : Applied Physics Laboratory
--              : Johns Hopkins Road
--              : Laurel, Maryland  20707
-- DDN Address  : dgg@aplvax
-- Copyright    : (c) 1986 David G. Gawron
-- Date created :  October  1986
-- Release date :  November 1986
-- Last update  :  Gawron, October  1986
-- Machine/System Compiled/Run on : DEC VAX 11/750, DEC Ada v1.3
--
---------------------------------------------------------------
--
-- Keywords     :  Demonstration of date_package
--
-- Abstract     :
--
--  This procedure demonstrates the use of several date_package
-- entry points.  The procedure generates a calendar-like listing
-- of a month that includes a countdown by days to some date
-- specified by the user.  Try it for a 'days till Christmas'
-- listing.
--
------------------ Revision history ---------------------------
--
-- DATE         VERSION    AUTHOR                  HISTORY
-- 10/86        1.0     Gawron                  Initial release
--
------------------ Distribution and Copyright -----------------
--
-- This prologue must be included in all copies of this software.
--
-- This software is copyright by the author.
--
-- This software is released to the Ada community.
-- Restrictions on use or distribution:  NONE
--
------------------ Disclaimer ---------------------------------
--
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered.  The user is advised to
-- test the software thoroughly before relying on it.  The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.
--
-------------------END-PROLOGUE--------------------------------



with text_io;
with date_package;



procedure days_till is


    package date is new date_package(short_value => short_integer,
                     long_value  => integer);


    use text_io;
    use date;


    -- The date package doesn't provide the month names
    -- so this type is used.
    --
    type month_name_type is
    (January, February, March, April, May, June,
     July, August, September, October, November, December);



    -- These will specify the fixed date that will be counted
    -- down to.
    --
    target_year            : year_number_type;
    target_month        : month_number_type;
    target_day            : day_number_type;



    -- These will specify the year and month
    -- that will be printed.
    --
    base_year            : year_number_type;
    base_month            : month_number_type;



    -- These dates will be used to print the month
    -- in calendar form.
    --
    base_date_1            : date_type;
    base_date_2            : date_type;
    fixed_target_date        : date_type;



    -- days_till is the difference in days between the fixed
    -- date and the day of the month.
    --
    days_till            : day_delta_type;



    -- These are used in the layout of the values
    -- printed for a month.
    --
    column_setting_1        : positive_count;
    column_setting_2        : positive_count;



    -- This will be used to tell if the user wants to continue
    -- running the demo.
    --
    user_response        : character;



    -- The I/O for each type we deal with.
    --
    package year_io       is new integer_io(year_number_type);
    package month_io      is new integer_io(month_number_type);
    package day_io        is new integer_io(day_number_type);
    package day_name_io   is new enumeration_io(day_name_type);
    package month_name_io is new enumeration_io(month_name_type);
    package till_io       is new integer_io(day_delta_type);



    begin

    loop
    new_line (25);
    put_line ("This demo takes two dates as input.");
    put_line ("The first date given will be a target date of some");
    put_line ("future or past event.");
    put_line ("The second date given will specify the year and month");
    put_line ("to be printed in a style similar to a calendar.");
    new_line;
    put_line ("The printout will include a days-till count down to the");
    put_line ("target date.  For example, if you entered 12 25 1986 for");
    put_line ("the first date and 11 1986 for the second, then a");
    put_line ("print out of November 1986 will be generated and include");
    put_line ("a days-till Christmas count down.");
    new_line (2);

    put ("Valid year numbers are within the range ");
    year_io.put (year_number_type'first);
    put (" to ");
    year_io.put (year_number_type'last);
    put (",");
    new_line;
    put ("valid month numbers are within the range ");
    month_io.put (month_number_type'first);
    put (" to ");
    month_io.put (month_number_type'last);
    put (",");
    new_line;
    put ("and valid day numbers are within the range ");
    day_io.put (day_number_type'first);
    put (" to ");
    day_io.put (day_number_type'last);
    put (".");
    new_line (2);


    put ("Please enter a target month: ");
    month_io.get (target_month);
    new_line;
    put ("Please enter a target day: ");
    day_io.get (target_day);
    new_line;
    put ("Please enter a target year: ");
    year_io.get (target_year);
    new_line (2);

    -- The fixed date stays the same through out
    -- the procedure.
    --
    fixed_target_date := date_of (target_year, target_month, target_day);


    put ("Now enter the month to be printed out: ");
    month_io.get (base_month);
    new_line;
    put ("and the year : ");
    year_io.get (base_year);

    -- The dates are set up to be the first
    -- of the given month.
    --
    base_date_1 := date_of (base_year, base_month, 1);
    base_date_2 := base_date_1;


    -- The month name and year are printed at
    -- the top.
    --
    new_line (25);
    text_io.set_col (35);
    month_name_io.put (month_name_type'val(base_month - 1));
    year_io.put (base_year);
    text_io.new_line (2);


    -- The weekday names are printed.
    --
    column_setting_1 := 1;
    for day_name in day_name_type loop
        set_col (column_setting_1);
        day_name_io.put (day_name);
        column_setting_1 := column_setting_1 + 12;
    end loop;
    text_io.new_line (2);


    -- An offset into the week is calculated.  The offset
    -- places the start of the month on the correct day.
    --
    column_setting_1 :=
        (day_name_type'pos(day_name (base_date_1)) * 12) + 1;

    column_setting_2 := column_setting_1;


    loop
        -- The days of the month are printed.
        --
        loop
        exit when (base_month /= month (base_date_1));
        set_col (column_setting_1);
        day_io.put (day (base_date_1));
        exit when (day_name (base_date_1) = Saturday) or
              ((base_month = 12) and (day (base_date_1) = 31));
        column_setting_1 := column_setting_1 + 12;
        base_date_1 := base_date_1 + 1;
        end loop;


        -- An the count down is printed below the
        -- day number.
        --
        loop
        exit when (base_month /= month (base_date_2));
        set_col (column_setting_2);
        days_till := fixed_target_date - base_date_2;
        text_io.put ("(");
        till_io.put (item  => days_till,
                 width => 1);
        text_io.put (")");
        exit when (day_name (base_date_2) = Saturday) or
              ((base_month = 12) and (day (base_date_2) = 31));
        column_setting_2 := column_setting_2 + 12;
        base_date_2 := base_date_2 + 1;
        end loop;


        -- When the month flips over or at the end of the
        -- year we know the printing is done.
        --
        exit when (base_month /= month (base_date_1)) or
              ((base_month = 12) and (day (base_date_1) = 31));


        -- Setup for the next week to be printed.
        --
        text_io.new_line (2);
        column_setting_1 := 1;
        column_setting_2 := 1;
        base_date_1 := base_date_1 + 1;
        base_date_2 := base_date_1;
    end loop;


    new_line (2);
    put ("Enter a Q to quit or any other character to continue: ");
    get (user_response);
    exit when (user_response = 'Q');


    end loop;


    exception
        when date_is_not_valid =>
        new_line (2);
        month_name_io.put (month_name_type'val(target_month - 1));
        put (" doesn't have that many days");
        if ((target_month = 2) and (target_day = 29)) then
            put (" in ");
            year_io.put (target_year);
        end if;
        put_line (".");

        when data_error =>
        new_line (2);
        put_line ("Input data out of range.  Bye!");


    end days_till;
--::::::::::
--friday_13th.ada
--::::::::::

-------- SIMTEL20 Ada Software Repository Prologue ------------
--
-- Unit name    : procedure days_till
-- Version      : 1.0
-- Authors      : David G. Gawron
--              : The Johns Hopkins University
--              : Applied Physics Laboratory
--              : Johns Hopkins Road
--              : Laurel, Maryland  20707
-- DDN Address  : dgg@aplvax
-- Copyright    : (c) 1986 David G. Gawron
-- Date created :  October  1986
-- Release date :  November 1986
-- Last update  :  Gawron, October  1986
-- Machine/System Compiled/Run on : DEC VAX 11/750, DEC Ada v1.3
--
---------------------------------------------------------------
--
-- Keywords     :  Demonstration of date_package
--
-- Abstract     :
--
--  This procedure demonstrates the use of several date_package
-- entry points.  The procedure generates a listing which contains
-- every Friday the 13th in the year range defined by the date
-- package.  In the end, each month is printed showing the number
-- of Friday the 13th's found for that month.
--
------------------ Revision history ---------------------------
--
-- DATE         VERSION    AUTHOR                  HISTORY
-- 10/86        1.0     Gawron                  Initial release
--
------------------ Distribution and Copyright -----------------
--
-- This prologue must be included in all copies of this software.
--
-- This software is copyright by the author.
--
-- This software is released to the Ada community.
-- Restrictions on use or distribution:  NONE
--
------------------ Disclaimer ---------------------------------
--
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered.  The user is advised to
-- test the software thoroughly before relying on it.  The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.
--
-------------------END-PROLOGUE--------------------------------



with text_io;
with date_package;



procedure friday_13th is


    package date is new date_package(short_value => short_integer,
                     long_value  => integer);


    use text_io;
    use date;


    -- The date package doesn't provide the month names
    -- so this type is used.
    --
    type month_name_type is
    (January, February, March, April, May, June,
     July, August, September, October, November, December);



    -- These will keep track of stats for the number of times
    -- Friday the 13th shows up in a month.
    --
    type month_stats_type is
    array (month_name_type) of natural;

    month_stats            : month_stats_type;
    month_name            : month_name_type;
    total            : natural := 0;





    -- These will specify a possible date for Friday the 13th.
    --
    target_year            : year_number_type;
    target_month        : month_number_type;



    -- This will be used to find all Friday 13th.
    -- dates.
    --
    base_date            : date_type;



    -- The I/O for each type we deal with.
    --
    package year_io       is new integer_io(year_number_type);
    package month_name_io is new enumeration_io(month_name_type);
    package stats_io      is new integer_io(natural);



    begin

    new_line (25);
    put_line ("This demo finds all Friday the 13th's from");
    year_io.put (year_number_type'first);
    put (" to ");
    year_io.put (year_number_type'last);
    put (".");
    new_line (2);


    for i in month_name_type loop
        month_stats(i) := 0;
    end loop;


    for base_year in year_number_type loop
        for base_month in month_number_type loop
        base_date := date_of (base_year, base_month, 13);
        if (day_name (base_date) = Friday) then
            month_name := month_name_type'val(base_month - 1);
            month_stats(month_name) := month_stats(month_name) + 1;

            month_name_io.put (month_name);
            set_col (12);
            year_io.put (base_year);
            new_line;
        end if;
        end loop;
    end loop;


    for i in month_name_type loop
        total := total + month_stats(i);
    end loop;

    new_line;
    put_line ("These are the statistics for Friday the 13th");
    put_line ("density per month.");
    new_line;
    put ("There were ");
    stats_io.put (item => total, width => 1);
    put_line (" Friday the 13th's.");
    new_line;


    for i in month_name_type loop
        month_name_io.put (i);
        set_col (12);
        stats_io.put (item => month_stats(i), width => 1);
        new_line;
    end loop;


    end friday_13th;
--::::::::::
--test_ranges.ada
--::::::::::

-------- SIMTEL20 Ada Software Repository Prologue ------------
--
-- Unit name    : procedure test_ranges
-- Version      : 1.0
-- Authors      : David G. Gawron
--              : The Johns Hopkins University
--              : Applied Physics Laboratory
--              : Johns Hopkins Road
--              : Laurel, Maryland  20707
-- DDN Address  : dgg@aplvax
-- Copyright    : (c) 1986 David G. Gawron
-- Date created :  October  1986
-- Release date :  November 1986
-- Last update  :  Gawron, October  1986
-- Machine/System Compiled/Run on : DEC VAX 11/750, DEC Ada v1.3
--
---------------------------------------------------------------
--
-- Keywords     :  Demonstration of date_package
--
-- Abstract     :
--
--  This procedure demonstrates error trapping when using date
-- arithmetic.
--
------------------ Revision history ---------------------------
--
-- DATE         VERSION    AUTHOR                  HISTORY
-- 10/86        1.0     Gawron                  Initial release
--
------------------ Distribution and Copyright -----------------
--
-- This prologue must be included in all copies of this software.
--
-- This software is copyright by the author.
--
-- This software is released to the Ada community.
-- Restrictions on use or distribution:  NONE
--
------------------ Disclaimer ---------------------------------
--
-- This software and its documentation are provided "AS IS" and
-- without any expressed or implied warranties whatsoever.
-- No warranties as to performance, merchantability, or fitness
-- for a particular purpose exist.
--
-- Because of the diversity of conditions and hardware under
-- which this software may be used, no warranty of fitness for
-- a particular purpose is offered.  The user is advised to
-- test the software thoroughly before relying on it.  The user
-- must assume the entire risk and liability of using this
-- software.
--
-- In no event shall any person or organization of people be
-- held responsible for any direct, indirect, consequential
-- or inconsequential damages or lost profits.
--
-------------------END-PROLOGUE--------------------------------



with text_io;
with date_package;



procedure test_ranges is


    package date is new date_package(short_value => short_integer,
                     long_value  => integer);


    use text_io;
    use date;


    -- This will be used as a base to force range constraint errors
    -- when doing date arithmetic.
    --
    first_date            : date_type;
    todays_date            : date_type;
    last_date            : date_type;
    test_date            : date_type;



    begin

    new_line (25);
    put_line ("This demo forces range constraint errors to see");
    put_line ("how well the date package handles date arithmetic.");
    new_line;
    put_line ("The tests should all produce messages with");
    put_line ("a banner indicating the test number.  Any");
    put_line ("number skiped will indicate that something is");
    put_line ("wrong in the date package.");
    new_line;
    put_line ("These cases will be tested:");
    put_line ("   1) Subtract one day from the first valid date.");
    put_line ("   2) Add one day to the last valid date.");
    put_line ("   3) Subtract full range of days from the current date.");
    put_line ("   4) Add full range of days to the current date.");
    new_line (3);


    first_date  := date_of (year_number_type'first, 1, 1);
    todays_date := current_date;
    last_date   := date_of (year_number_type'last, 12, 31);


    begin
        test_date := first_date - 1;
        exception
        when result_out_of_range =>
            put_line ("------- Test 1 OK -------");
    end;


    begin
        test_date := last_date + 1;
        exception
        when result_out_of_range =>
            put_line ("------- Test 2 OK -------");
    end;


    begin
        test_date := todays_date - day_delta_type'last;
        exception
        when result_out_of_range =>
            put_line ("------- Test 3 OK -------");
    end;


    begin
        test_date := todays_date + day_delta_type'last;
        exception
        when result_out_of_range =>
            put_line ("------- Test 4 OK -------");
    end;

    end test_ranges;