From mboxrd@z Thu Jan  1 00:00:00 1970
X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on polar.synack.me
X-Spam-Level: 
X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00 autolearn=ham
	autolearn_force=no version=3.4.4
X-Google-Language: ENGLISH,ASCII-7-bit
X-Google-Thread: 103376,ed5f02e263fe4d2d
X-Google-Attributes: gid103376,public
From: mfeldman@seas.gwu.edu (Michael Feldman)
Subject: Re: Scientific Unit Checking??
Date: 1997/04/09
Message-ID: <5if6jm$htq@felix.seas.gwu.edu>
X-Deja-AN: 231725837
References: <334897B1.26258D03@usq.edu.au>
Organization: George Washington University
Newsgroups: comp.lang.ada
Date: 1997-04-09T00:00:00+00:00
List-Id: <comp.lang.ada>


In article <334897B1.26258D03@usq.edu.au>, Ron House  <house@usq.edu.au> wrote:
>Some time ago I read about a package for implementing
>scientific unit checks in Ada.
>
>Can anyone tell me where to locate this package or
>any information about it?
>
>Many thanks...
>
>-- 
>Ron House

Here is a relatively straightforward approach using discriminants
(taken from my data structures book, Chapter 6). You can use this
for educational purposes. If you modify it, you must leave my header
comments in place, adding your own if you wish.

Oh - UPPERCASE RESERVED WORD ALERT! :-)

Mike Feldman

--- cut here for code ---

PACKAGE Metric_System IS
------------------------------------------------------------------
--| Specification for Metric System Package
--| Author: Michael B. Feldman, The George Washington University 
--| Last Modified: September 1995                                     
------------------------------------------------------------------
 
--  Type definition
 
  TYPE    Metric(Mass, Length, Time : Integer) IS PRIVATE;

  -- constrained subtypes

  SUBTYPE Scalar   IS Metric(0, 0, 0);
 
  SUBTYPE Accel    IS Metric(0, 1, -2);
  SUBTYPE Area     IS Metric(0, 2, 0);
  SUBTYPE Length   IS Metric(0, 1, 0);
  SUBTYPE Distance IS Metric(0, 1, 0);
  SUBTYPE Mass     IS Metric(1, 0, 0);
  SUBTYPE Time     IS Metric(0, 0, 1);
  SUBTYPE Velocity IS Metric(0, 1, -1);
  SUBTYPE Volume   IS Metric(0, 3, 0);

  -- exported exception

  Dimension_Error : EXCEPTION;

  -- exported unit constants; these will be defined in full below

  Gram       : CONSTANT Metric;
  METER      : CONSTANT Metric;
  SEC        : CONSTANT Metric;
  Square_M   : CONSTANT Metric;
  Cubic_M    : CONSTANT Metric;
  M_per_Sec  : CONSTANT Metric;
  M_per_Sec2 : CONSTANT Metric;
 
  FUNCTION "*" (Left : Float; Right : Metric) RETURN Metric;
  -- Pre:  Left and Right are defined
  -- Post: constructor: produces a metric quantity from a Float one

  FUNCTION Value(Left : Metric) RETURN Float;
  -- Pre:  Left is defined
  -- Post: selector: returns the Float (dimensionless) part
  --   of a metric quantity

  FUNCTION "<"  (Left, Right : Metric) RETURN Boolean;
  FUNCTION "<=" (Left, Right : Metric) RETURN Boolean;
  FUNCTION ">"  (Left, Right : Metric) RETURN Boolean;
  FUNCTION ">=" (Left, Right : Metric) RETURN Boolean;
  -- Pre:    Left and Right are defined
  -- Post:   the usual comparison operations
  -- Raises: Dimension_Error if Left and Right 
  --   have different dimensions

  FUNCTION "+" (Right : Metric) RETURN Metric;
  FUNCTION "-" (Right : Metric) RETURN Metric;
  FUNCTION "abs" (Right : Metric) RETURN Metric;
  -- Pre:  Right is defined
  -- Post: the usual monadic arithmetic operations;
  --   the dimensions of Right are, of course, preserved
 
  FUNCTION "+" (Left, Right : Metric) RETURN Metric;
  FUNCTION "-" (Left, Right : Metric) RETURN Metric;
  -- Pre:    Left and Right are defined
  -- Post:   the usual additive operations are performed on the
  --   numeric parts of Left and Right; the dimensions are preserved
  -- Raises: Dimension_Error if Left and Right
  --   have different dimensions

  FUNCTION "*" (Left, Right : Metric) RETURN Metric;
  FUNCTION "/" (Left, Right : Metric) RETURN Metric;
  -- Pre:    Left and Right are defined
  -- Post:   the usual multiplication and division operations 
  --   are performed on the numeric parts of Left and Right; 
  --   the dimensions are added pairwise (multiplication)
  --   or subtracted pairwise (division)
  --   Left and Right need not have the same dimensions.
  
PRIVATE

  -- A Metric quantity is a 3-discriminant variant record,
  -- with no default values. Each object of the type must
  -- therefore be constrained to a subtype, that is, to a
  -- fixed set of dimensions. This is physically realistic.

  TYPE Metric(Mass, Length, Time : Integer) IS RECORD
    Value : Float := 0.0;
  END RECORD;
 
  Gram       : CONSTANT Metric := (1, 0, 0, 1.0);
  Meter      : CONSTANT Metric := (0, 1, 0, 1.0);
  Sec        : CONSTANT Metric := (0, 0, 1, 1.0);
  Square_M   : CONSTANT Metric := (0, 2, 0, 1.0);
  Cubic_M    : CONSTANT Metric := (0, 3, 0, 1.0);
  M_per_Sec  : CONSTANT Metric := (0, 1, -1, 1.0);
  M_per_Sec2 : CONSTANT Metric := (0, 1, -2, 1.0);
 
END Metric_System;


PACKAGE BODY Metric_System IS
------------------------------------------------------------------
--| This is the implementation of the package Metric_System.
--| Author: Michael B. Feldman, The George Washington University 
--| Last Modified: September 1995                                     
------------------------------------------------------------------
 
  -- local function to check whether its arguments have the same dimensions

  FUNCTION SameDimensions(Left, Right :Metric) RETURN Boolean IS
  BEGIN
    RETURN (Left.Length = Right.Length) AND
           (Left.Mass = Right.Mass)     AND
           (Left.Time = Right.Time);
  END SameDimensions;

  FUNCTION "*" (Left : Float; Right : Metric) RETURN Metric IS
  BEGIN
    RETURN (Right.Mass, Right.Length, Right.Time, Left * Right.Value);
  END "*";
 
  FUNCTION Value(Left : Metric) RETURN Float IS
  BEGIN
    RETURN Left.Value;
  END Value;

  -- comparison operators

  FUNCTION "<" (Left, Right : Metric) RETURN Boolean IS
  BEGIN
    IF SameDimensions(Left, Right) THEN
      RETURN Left.Value < Right.Value;
    ELSE
      RAISE Dimension_Error;
    END IF;
  END "<";

  FUNCTION "<=" (Left, Right : Metric) RETURN Boolean IS
  BEGIN
    IF SameDimensions(Left, Right) THEN
      RETURN Left.Value <= Right.Value;
    ELSE
      RAISE Dimension_Error;
    END IF;
  END "<=";

  FUNCTION ">" (Left, Right : Metric) RETURN Boolean IS
  BEGIN
    IF SameDimensions(Left, Right) THEN
      RETURN Left.Value > Right.Value;
    ELSE
      RAISE Dimension_Error;
    END IF;
  END ">";

  FUNCTION ">=" (Left, Right : Metric) RETURN Boolean IS
  BEGIN
    IF SameDimensions(Left, Right) THEN
      RETURN Left.Value >= Right.Value;
    ELSE
      RAISE Dimension_Error;
    END IF;
  END ">=";

  --  monadic arithmetic operators
 
  FUNCTION "+" (Right : Metric) RETURN Metric IS
  BEGIN
    RETURN Right;
  END "+";
 
  FUNCTION "-" (Right : Metric) RETURN Metric IS
  BEGIN
    RETURN (Right.Mass, Right.Length, Right.Time, -Right.Value);
  END "-";
 
  FUNCTION "ABS" (Right : Metric) RETURN Metric IS
  BEGIN
    RETURN (Right.Mass, Right.Length, Right.Time, ABS(Right.Value));
  END "ABS";
 
  --  dyadic arithmetic operators
 
  --  "+" and "-" require two variables of the same subtype,
  --  they return a variable of the same subtype passed
 
  FUNCTION "+" (Left, Right : Metric) RETURN Metric IS
  BEGIN
    IF SameDimensions(Left, Right) THEN
      RETURN (Left.Mass, Left.Length, Left.Time, Left.Value + Right.Value);
    ELSE
      RAISE Dimension_Error;
    END IF;
  END "+";
 
  FUNCTION "-" (Left, Right : Metric) RETURN Metric IS
  BEGIN
    IF SameDimensions(Left, Right) THEN
      RETURN (Left.Mass, Left.Length, Left.Time, Left.Value - Right.Value);
    ELSE
      RAISE Dimension_Error;
    END IF;
  END "-";

  --  "*" and "/" require variables of any subtype
  --  of Metric.  The subtype of the variable returned depends on
  --  the types passed and how the operation combines the units.
 
  FUNCTION "*" (Left, Right : Metric) RETURN Metric IS
  BEGIN
    RETURN (Left.Mass + Right.Mass, Left.Length + Right.Length, 
            Left.Time + Right.Time, Left.Value * Right.Value);
  END "*";
 
  FUNCTION "/" (Left, Right : Metric) RETURN Metric IS
  BEGIN
    RETURN (Left.Mass - Right.Mass, Left.Length - Right.Length, 
            Left.Time - Right.Time, Left.Value / Right.Value);
  END "/";
 
END Metric_System;

WITH Ada.Text_IO;
WITH Ada.Float_Text_IO;
WITH Metric_System; USE Metric_System;
PROCEDURE Test_Metric IS
------------------------------------------------------------------
--| Test some of the operations of the metric system package
--| Author: Michael B. Feldman, The George Washington University 
--| Last Modified: September 1995                                     
------------------------------------------------------------------

  V   : Velocity;
  T   : Time;
  D   : Length;
  A   : Area;
  Vol : Volume;

BEGIN -- Test_Metric

  -- these operations should all work correctly

  V := 23.0 * M_per_Sec;
  T := 3600.0 * Sec;

  D := V * T;

  Ada.Text_IO.Put("Distance = Rate * Time works as advertised");
  Ada.Text_IO.New_Line;
  Ada.Text_IO.Put("Distance is ");
  Ada.Float_Text_IO.Put(Item => Value(D), Fore => 1, Aft => 2, Exp => 0);
  Ada.Text_IO.Put(" meters.");
  Ada.Text_IO.New_Line;
  Ada.Text_IO.New_Line;

  D := 3.0 * Meter;
  A := D * D;

  Ada.Text_IO.Put("Area = Distance * Distance works as advertised");
  Ada.Text_IO.New_Line;
  Ada.Text_IO.Put("Area is ");
  Ada.Float_Text_IO.Put(Item => Value(A), Fore => 1, Aft => 2, Exp => 0);
  Ada.Text_IO.Put(" square meters.");
  Ada.Text_IO.New_Line;
  Ada.Text_IO.New_Line;

  Vol := A * D;

  Ada.Text_IO.Put("Volume = Area * Distance works as advertised");
  Ada.Text_IO.New_Line;
  Ada.Text_IO.Put("Volume is ");
  Ada.Float_Text_IO.Put(Item => Value(Vol), Fore => 1, Aft => 2, Exp => 0);
  Ada.Text_IO.Put(" cubic meters.");
  Ada.Text_IO.New_Line;
  Ada.Text_IO.New_Line;

  D := D + D;

  Ada.Text_IO.Put("Distance = Distance + Distance works as advertised");
  Ada.Text_IO.New_Line;
  Ada.Text_IO.Put("Distance is ");
  Ada.Float_Text_IO.Put(Item => Value(D), Fore => 1, Aft => 2, Exp => 0);
  Ada.Text_IO.Put(" meters.");
  Ada.Text_IO.New_Line;
  Ada.Text_IO.New_Line;

  BEGIN -- block for exception handler
    D := D * D;
    Ada.Text_IO.Put("Distance = Distance * Distance worked, but should not");
    Ada.Text_IO.New_Line;
  EXCEPTION
    WHEN Constraint_Error =>
      Ada.Text_IO.Put
        ("Constraint Error Raised on Distance = Distance * Distance");
      Ada.Text_IO.New_Line;
    WHEN Dimension_Error =>
      Ada.Text_IO.Put
        ("Dimension Error Raised on Distance = Distance * Distance");
      Ada.Text_IO.New_Line;
  END; -- exception block

  BEGIN -- block for exception handler
    D := T + D;
    Ada.Text_IO.Put("Distance = Time + Distance worked, but should not");
    Ada.Text_IO.New_Line;
  EXCEPTION
    WHEN Constraint_Error =>
      Ada.Text_IO.Put("Constraint Error Raised on Distance = Time + Distance");
      Ada.Text_IO.New_Line;
    WHEN Dimension_Error =>
      Ada.Text_IO.Put("Dimension Error Raised on Distance = Time + Distance");
      Ada.Text_IO.New_Line;
  END; -- exception block

END Test_Metric;