File : units.adb
with Ada.Strings.Fixed;
package body Units is
-- List of prefix values.
scale : constant array (Prefix) of Accuracy := (
yocto => 10.0**(-24), zepto => 10.0**(-21), atto => 10.0**(-18),
femto => 10.0**(-15), pico => 10.0**(-12), nano => 10.0**(-9),
micro => 10.0**(-6), milli => 10.0**(-3), centi => 10.0**(-2),
deci => 10.0**(-1), deka => 10.0**1, hecto => 10.0**2, kilo => 10.0**3,
kibi => 2.0**10, mega => 10.0**6, mebi => 2.0**20, giga => 10.0**9,
gibi => 2.0**30, tera => 10.0**12, tebi => 2.0**40, peta => 10.0**15,
pebi => 2.0**50, exa => 10.0**18, exbi => 2.0**60, zetta => 10.0**21,
yotta => 10.0**24);
-- Negate a value. Very simple.
function "-" (a : Unit) return Unit is
begin
return Unit'(value => -a.value, dim => a.dim);
end "-";
-- Multiply values and dimensions. Please note, that exponents are added.
function "*" (a, b : Unit) return Unit is
begin
return Unit'(value => a.value * b.value, dim => a.dim * b.dim);
end "*";
function "*" (a, b : Dimension) return Dimension is
begin
return Dimension'(
length => a.length + b.length,
time => a.time + b.time,
mass => a.mass + b.mass,
current => a.current + b.current,
temperature => a.temperature + b.temperature,
substance_amount => a.substance_amount + b.substance_amount,
luminous_intensity => a.luminous_intensity + b.luminous_intensity);
end "*";
-- Divide values and dimensions. Exponents are subtracted.
function "/" (a, b : Unit) return Unit is
begin
return Unit'(value => a.value / b.value, dim => a.dim / b.dim);
end "/";
function "/" (a, b : Dimension) return Dimension is
begin
return Dimension'(
length => a.length - b.length,
time => a.time - b.time,
mass => a.mass - b.mass,
current => a.current - b.current,
temperature => a.temperature - b.temperature,
substance_amount => a.substance_amount - b.substance_amount,
luminous_intensity => a.luminous_intensity - b.luminous_intensity);
end "/";
-- Raise to a given power. Exponents are multiplied.
function "**" (a : Unit; b : Integer) return Unit is
begin
return Unit'(value => a.value ** b, dim => a.dim ** b);
end "**";
function "**" (a : Dimension; b : Integer) return Dimension is
begin
return Dimension'(
length => a.length * b,
time => a.time * b,
mass => a.mass * b,
current => a.current * b,
temperature => a.temperature * b,
substance_amount => a.substance_amount * b,
luminous_intensity => a.luminous_intensity * b);
end "**";
-------------------
-- Special_Units --
-------------------
package body Special_Units is
-- Convert to a generic unit
function "+" (a : Special_Unit) return Unit is
begin
return Unit'(value => a.value, dim => dim);
end "+";
-- Add two values on the same dimension point
function "+" (a, b : Special_Unit) return Special_Unit is
begin
return Special_Unit'(value => a.value + b.value);
end "+";
-- Subtract two values on the same dimension point
function "-" (a, b : Special_Unit) return Special_Unit is
begin
return Special_Unit'(value => a.value - b.value);
end "-";
-- Convert a unit to a special one. BUG! May raise error on runtime.
function "+" (a : Unit) return Special_Unit is
begin
if dim /= a.dim then
raise Dimension_Error;
end if;
return Special_Unit'(value => a.value);
end "+";
-- Convert an numeric value to a dimensional one.
function "+" (v : Accuracy) return Special_Unit is
begin
return Special_Unit'(value => v);
end "+";
-- Convert an numeric value with a prefix to a dimensional one.
function "*" (v : Accuracy; p : Prefix) return Special_Unit is
begin
return Special_Unit'(value => v * scale (p));
end "*";
end Special_Units;
-- Generate a human readable string. Keep an eye on the special mass unit
-- and of missing units.
function To_String (a : Unit) return String is
exp : constant String := To_String (a.dim);
use Ada.Strings.Fixed, Ada.Strings;
begin
if exp'Length = 0 then
return Trim (Accuracy'Image (a.value), Both);
else
return
Trim (Accuracy'Image (a.value / scale (kilo)**a.dim.mass), Both)
& ' ' & exp;
end if;
end To_String;
-- Generate a human readable string. Order the units to positive powers.
-- Using recursion returning a String in order to avoid heap memory.
function To_String (a : Dimension) return String is
type String_Access is access constant String;
type Unit_Data is record
exp : Integer;
unit : String_Access;
end record;
type String_Array is array (Positive range <>) of Unit_Data;
-- Expotentiate a unit to a given power.
function exp (unit : String; exponent : Positive) return String;
-- Collects all units above or below the division line.
function bruch (e : String_Array; below : Boolean) return String;
function exp (unit : String; exponent : Positive) return String is
use Ada.Strings.Fixed, Ada.Strings;
begin
if exponent = 1 then
return unit;
else
return unit & '^' & Trim (Integer'Image (exponent), Both);
end if;
end exp;
function bruch (e : String_Array; below : Boolean) return String is
begin
if e'Length = 0 then
return "";
else
declare
first : Unit_Data renames e (e'First);
rest : String := bruch (e (e'First + 1 .. e'Last), below);
begin
if first.exp = 0 or else (first.exp > 0) = below then
return rest;
else
declare
u : String := exp (first.unit.all, abs first.exp);
begin
if rest'Length = 0 then
return u;
else
return u & '*' & rest;
end if;
end;
end if;
end;
end if;
end bruch;
-- List of predefined unit names.
u1 : aliased constant String := "m";
u2 : aliased constant String := "kg";
u3 : aliased constant String := "s";
u4 : aliased constant String := "A";
u5 : aliased constant String := "K";
u6 : aliased constant String := "mol";
u7 : aliased constant String := "cd";
e : String_Array := (
Unit_Data'(a.length, u1'Access),
Unit_Data'(a.mass, u2'Access),
Unit_Data'(a.time, u3'Access),
Unit_Data'(a.current, u4'Access),
Unit_Data'(a.temperature, u5'Access),
Unit_Data'(a.substance_amount, u6'Access),
Unit_Data'(a.luminous_intensity, u7'Access));
-- Collect numerator and denumerator seperatly.
z : String := bruch (e, False);
n : String := bruch (e, True);
begin
if z'Length = 0 and n'Length = 0 then
return "";
elsif z'Length = 0 and n'Length /= 0 then
return "1/" & n;
elsif z'Length /= 0 and n'Length = 0 then
return z;
else
return z & '/' & n;
end if;
end To_String;
end Units;