Category : Files from Magazines
Archive   : DDJ0988.ZIP
Filename : GROSBERG.LIS

_OBJECT-ORIENTED DIMENSIONAL UNITS_
by
John A. Grosbery



Listing One

package float_unit is
type class is new float;
units_error : exception;

function "*" (left,right : class) return class;
-- This function is to overload the inherited
-- multiply function. Multiplying two dimensioned
-- numbers does not produce a number with the same
-- units, so this is an invalid operation. It will
-- raise the units_error exception.

-- The following multiplication functions provide for
-- multiplying a non-dimensional number (float or
-- integer) times a dimensional number (class). There
-- are two of each (one with float first, one with
-- class first) to make the multiplication functions
-- commutative.

function "*" (left : float; right : class) return class;
function "*" (left : class; right : float) return class;

function "*" (left : integer; right : class) return
class;
function "*" (left : class; right : integer) return
class;

function "/" (left,right : class) return class;
-- This function is to overload the inherited
-- divide function. Dividing two dimensioned numbers
-- does not produce a number with the same units, so
-- this is an invalid operation. It will raise the
-- units_error exception.

function "/" (left, right : class) return float;
-- This function divides two items of type class and
-- returns the result as type float. Dividing a
-- dimensioned number by another of the same
-- dimensioned produces a non-dimensional number.

-- The next two divide functions allow dividing a
-- dimensioned number by a non-dimensioned floating point
-- or integer number. Doing so produces a result with
-- the same dimensions as the dimensioned number.

function "/" (left : class; right : float) return class;
function "/" (left : class; right : integer) return
class;

function "**" (left:class; right:integer) return class;
-- This function is to overload the inherited
-- exponentiation function. Exponentiating
-- dimensioned numbers does not produce a
-- number with the same units, so this is an
-- invalid operation. It will raise the
-- units_error exception.

function image ( the_object :in class ) return string;
-- This function will take the_object of type
-- class and convert it to a string type. The
-- name "image" was chosen because the purpose of
-- this function is similar to that of Ada's "image"
-- attribute. This function and the following
-- decouple the units package from any input/output
-- device or package.


function value (the_string :in string) return class;
-- This function will take a string which is a valid
-- representation of an object of the type class and
-- convert it to the type class. If the_string
-- contains an invalid value, the constraint_error
-- exception will be raised. The name "value" was
-- used because the purpose of this function is
-- similar to Ada's "value" attribute.

end float_unit;

with text_io;

package body float_unit is
------------------------------------------------------------
function "*" (left,right : class) return class is
-- This function is to hide the inherited multiply
-- function. Multiplying two dimensioned numbers does
-- not produce a number with the same units, so
-- this is an invalid operation. If this function
-- is invoked, it will raise the units_error exception.

begin
-- Whole function invalid; force exception:

raise units_error;
return left * right;

-- Above return needed to satisfy compiler, but
-- it will never be executed.
end "*";

function "*" (left : float; right : class) return class
is
begin
return class(left * float(right));
end "*";


function "*" (left : class; right : float) return class
is
begin
return class( float(left) * right );
end "*";

function "*" (left : integer; right : class) return
class
is
begin
return class( float(left) * right );
end "*";

function "*" (left : class; right : integer) return
class
is
begin
return class( left * float(right) );
end "*";

function "/" (left,right : class) return class
is
begin
-- Whole function invalid; force exception:

raise units_error;
return class( float(left) / float(right));

-- Above return needed to satisfy compiler, but
-- it will never be executed.
end "/";

function "/" (left, right : class) return float
is
begin
return float(left) / float(right);
end "/";

function "/" (left : class; right : float) return class
is
begin
return class( float(left) / right);
end "/";

function "/" (left : class; right : integer) return class
is
begin
return class( float(left) / float(right) );
end "/";

function "**" (left:class; right:integer) return class
is
begin
raise units_error;
return class( float(left) ** right);
end "**";

package fio is new text_io.float_io(class);
-- Fio will be needed by image and value, below.

function image ( the_object :in class ) return string
is
buffer : string(1..14);
begin
fio.put(buffer, the_object);
return buffer;
end image;

function value (the_string :in string) return class
is
buffer : class;
last : positive;
begin
fio.get(the_string, buffer, last);
return buffer;
end value;

end float_unit;




Listing Two

------------------------------------------------------------
with float_unit;

generic
type class_a is digits<>;
type class_b is digits <>;
package product_unit is

type class is new float_unit.class;

function "*"(left : class_a;
right : class_b) return class;

function "*"(left : class_b;
right : class_a) return class;

function "/"(left : class;
right : class_a) return class_b;

function "/"(left : class;
right : class_b) return class_a;

end product_unit;

package body product_unit is

function "*"(left : class_a;
right : class_b) return class
is
begin
return class(float(left) * float(right));
end "*";

function "*"(left : class_b;
right : class_a) return class
is
begin
return class(float(left) * float(right));
end "*";

function "/"(left : class;
right : class_a) return class_b
is
begin
return class_b(float(left) / float(right));
end "/";

function "/"(left : class;
right : class_b) return class_a
is
begin
return class_a(float(left) / float(right));
end "/";

end product_unit;



Listing Three
------------------------------------------------------------

with float_unit;

generic
type numerator_class is digits <>;
type denominator_class is digits <>;
package quotient_unit is

type class is new float_unit.class;

function "/"(left : numerator_class;
right : denominator_class
) return class;

function "*"(left : class;
right : denominator_class
) return numerator_class;

function "*"(left : denominator_class;
right : class
) return numerator_class;

end quotient_unit;

package body quotient_unit is

function "/"(left : numerator_class;

right : denominator_class) return class
is
begin
return class(float(left) / float(right));
end "/";

function "*"(left : class;
right : denominator_class
) return numerator_class
is
begin
return numerator_class(float(left) * float(right));
end "*";

function "*"(left : denominator_class;
right : class
) return numerator_class
is
begin
return numerator_class(float(left) * float(right));
end "*";

end quotient_unit;



Example 1: Using the form for a package construct


package float_unit is
type class is new float;

function"*"(left : float;
right: class
) return class;

function "/" (left: class;
right: float
) return class;

-- etc...
end float_unit;



Example 2: Creating objects of the hour glass

with hour; use hour;
procedure time_card is
-- Create the objects:
hours_worked : hour.class;
job_1 : hour.class;
job_2 : hour.class;

begin
-- Give them each a value:
job_1 := 8.0;
job_2 := 5.5;
hours_worked := job_1 + job_2;

end time_card;



Example 3: Using the hour class and a new mile class to create
the mile_per_hour class

with float_unit;
package mile is new unit;

with float_unit;
with hour;
with mile;

package mile_per_hour is
type class is new float_unit.class;

function "/"(left : mile.class;
right: hour.class
) return class;

end mile_per_hour;


Example 4: Installing the specification and the body for the
packages listed in Example 2 and 3

with hour;
with mile;
with quotient_unit;

package mile_per_hour is new quotient_unit(
numerator_class => mile.class,
denominator_class => hour.class);


Example 5: Creating new composite units by applying an existing
generic package as many times as necessary. In this case, a
package for cubic feet is created from miles/hour.

with unit;
package foot is new unit;

with foot;
with product_unit;
package square_foot is new product_unit(
class_a => foot,
class_b => foot);


with foot;
with square_foot;
with product_unit;
package cubic_foot is new product_unit(
class_a => foot,
class_b => square_foot);



Example 6: Converting routines to couple a package with other
packages

with float_unit;
with hour;
with mile;
with mile_per_second;

package mile_per_hour is
type class is new float_unit.class;

function "/"(left : mile.class;
right : hour.class
) return class;


function convert (mps :
miles_per_second.class
) return class;
end mile_per_hour;



Example 7: Modelling relationships on objects


with mile_per_hour;
with mile_per_second;
package mph_mps_convert is

function relation(mph :
mile_per_hour.class)
return mile_per_second.class;

function relation(mps :
mile_per_second.class)
return mile_per_hour.class;
end mph_mps_convert;


Example 8: Generalizing relationship objects for dimensional unit
applications by creating a class that provides functions to go
both ways. This generalization process is implemented as a
generic package that imports the conversion factor and the two
objects that are to be related.


generic
-- Import one kind of class:
type class_a is digits <>;
-- Import the other kind:
type class_b is digits <>;
-- Import the conversion factor
a_to_b_factor : in float := 1.0;
package class_a_class_b_convert is

function relation (a : class_a
) return class_b;


function relation (b : class_b
) return class_a;

end class_a_class_b_convert;


package body class_a_class_b_convert is

function relation (a : class_a
) return class_b
is
begin
return class_b(float(a) *
a_to_b_factor);
end relation;


function relation (b : class_b
) return class_a;
is
begin
return class_a(float(b) /
a_to_b_factor);
end relation;

end class_a_class_b_convert;



Example 9: Using the relationship objects described in Example 8


with miles_per_hour;
with miles_per_second;
with class_a_class_b_convert;
package mph_mps_convert is
new class_a_class_b_convert(
class_a => miles_per_hour.class,
class_b => miles_per_second.class,
a_to_b_factor => 3600.0);


Example 10: Code fragment showing the use of the mph_mps.convert
object created in Example 9 to convert 60 mile_per_hour into
mile_per_second


with miles_per_hour; use miles_per_hour;
with miles_per_second; use miles_per_second;
with mph_mps_convert;
...
mph : miles_per_hour.class := 60.0;
mps : miles_per_second.class;
...
mps := mph_mps_convert.relation(mph);
...