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

Text File | 1988-05-03 | 7.0 KB | 192 lines

-------- SIMTEL20 Ada Software Repository Prologue ------------
--                                                           -*
-- Unit name    : SET_PACKAGE
-- Version      : 1.0
-- Author       : Mike Linnig
--              : Texas Instruments Ada Technology Branch
--              : PO Box 801, MS 8007
--              : McKinney, TX  75069
-- DDN Address  : linnig%ti-eg at csnet-relay
-- Copyright    : (c)
-- Date created :  27 June 85
-- Release date :  27 June 85
-- Last update  :  27 June 85
-- Machine/System Compiled/Run on : DG MV 10000 with ROLM ADE
--                    DEC VAX 11/780 with DEC Ada
--                                                           -*
---------------------------------------------------------------
--                                                           -*
-- Keywords     :  SET, SET MANIPULATION
----------------:
--
-- Abstract     :  Set_Package contains a series of generic
----------------:  routines which can be instantiated to create
-- routines which provide a series of set manipulation functions
-- for sets of enumeration or numeric objects.  The functions in
-- Set_Package include:
--    set intersection
--    set union
--    set membership
--    set element count
-- and others
--
-- The code in this package was extracted from Chapter 15, Section 3
-- (15.3) of Grady Booch's Software Engineering with Ada book.
-- See 15.3 for further documentation on the functions.
--
--                                                           -*
------------------ Revision history ---------------------------
--                                                           -*
-- DATE         VERSION    AUTHOR                  HISTORY
-- 19850627    1.0    Mike Linnig        Initial Release
--                                                           -*
------------------ Distribution and Copyright -----------------
--                                                           -*
-- This prologue must be included in all copies of this software.
--
-- This software is released to the Ada community.
-- This software is released to the Public Domain (note:
--   software released to the Public Domain is not subject
--   to copyright protection).
-- 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 Universe IS (<>);
PACKAGE Set_Package IS

  TYPE Set IS PRIVATE;
  NULL_SET: constant SET;

  FUNCTION "*"  (Set_1 : Set; Set_2 : Set) RETURN Set;
  FUNCTION "+"  (Element : Universe; Set_1 : Set) RETURN Set;
  FUNCTION "+"  (Set_1 : Set; Set_2 : Set) RETURN Set;
  FUNCTION "+"  (Set_1 : Set; Element : Universe) RETURN Set;
  FUNCTION "-"  (Set_1 : Set; Set_2 : Set) RETURN Set;
  FUNCTION "-"  (Set_1 : Set; Element : Universe) RETURN Set;
  FUNCTION "<"  (Set_1 : Set; Set_2 : Set) RETURN Boolean;
  FUNCTION "<=" (Set_1 : Set; Set_2 : Set) RETURN Boolean;

  FUNCTION Is_A_Member (Element : Universe; Of_Set : Set) RETURN Boolean;
  FUNCTION Is_Empty    (Set_1 : Set) RETURN Boolean;

  SUBTYPE Number IS Integer
                      RANGE 0 .. (Universe'Pos (Universe'Last) -
                                  Universe'Pos (Universe'First) + 1);

  FUNCTION Number_In (Set_1 : Set) RETURN Number;

PRIVATE
  TYPE Set IS ARRAY (Universe) OF Boolean;

  Null_Set : CONSTANT Set := Set'(OTHERS => False);

END Set_Package;

--=====================================================================
PRAGMA PAGE;

Package body set_package is

  FUNCTION "*"  (Set_1 : Set; Set_2 : Set) RETURN Set is
        -- intersection
        begin
                return(set_1 and set_2);
        end"*";
-------------------------------------------------------------------------


  FUNCTION "+"  (Element : Universe; Set_1 : Set) RETURN Set is
        value_set: set := set_1;
  BEGIN
        VALUE_SET(ELEMENT) := TRUE;
        RETURN VALUE_SET;
  END "+";
-------------------------------------------------------------------------
  FUNCTION "+"  (Set_1 : Set; Set_2 : Set) RETURN Set is
  BEGIN
        RETURN (SET_1 OR SET_2);
  END "+";

-------------------------------------------------------------------------
  FUNCTION "+"  (Set_1 : Set; Element : Universe) RETURN Set is
        VALUE_SET: SET:= SET_1;

  BEGIN
        VALUE_SET(ELEMENT) := TRUE;
        RETURN VALUE_SET;
  END "+";

-------------------------------------------------------------------------
  FUNCTION "-"  (Set_1 : Set; Set_2 : Set) RETURN Set is
  BEGIN
        RETURN (SET_1 AND (NOT SET_2));
  END "-";
-------------------------------------------------------------------------
  FUNCTION "-"  (Set_1 : Set; Element : Universe) RETURN Set is
        VALUE_SET: SET:= SET_1;

  BEGIN
        VALUE_SET(ELEMENT) := FALSE;
        RETURN VALUE_SET;
  END "-";
-------------------------------------------------------------------------
  FUNCTION "<=" (Set_1 : Set; Set_2 : Set) RETURN Boolean is
        VALUE_SET:SET:= (set_1 and set_2);
  BEGIN
        RETURN (value_set = set_1);
  END "<=";
-------------------------------------------------------------------------
  FUNCTION "<" (Set_1 : Set; Set_2 : Set) RETURN Boolean is
        VALUE_SET:SET:= (set_1 and set_2);
  BEGIN
        RETURN ((value_set = set_1) and (value_set/= set_2));
  END "<";
-------------------------------------------------------------------------
  FUNCTION Is_A_Member (Element : Universe; Of_Set : Set) RETURN Boolean
 is
  BEGIN
        return of_set(element);
  end is_a_member;
-------------------------------------------------------------------------
  FUNCTION Is_Empty    (Set_1 : Set) RETURN Boolean is

  begin
        return (set_1 = null_set);
  end is_empty;
-------------------------------------------------------------------------
  FUNCTION Number_In (Set_1 : Set) RETURN Number is

        count: integer:= 0;

  begin
        for index in universe
          loop
            if set_1(index) then
              count:= count +1;
            end if;
          end loop;
        return count;
  end number_in;
END SET_PACKAGE;