1-- PragmAda Reusable Component (PragmARC) 2-- Copyright (C) 2014 by PragmAda Software Engineering. All rights reserved. 3-- ************************************************************************** 4-- 5-- Rational numbers bounded only by Integer'Last and available memory 6-- 7-- History: 8-- 2014 Apr 01 J. Carter V1.0--Initial release 9-- 10with Ada.Strings.Fixed; 11with Ada.Strings.Unbounded; 12 13package body PragmARC.Rational_Numbers is 14 function GCD (Left : Unbounded_Integer; Right : Unbounded_Integer) return Unbounded_Integer; 15 -- Greatest common divisor; signs are ignored 16 17 function LCM (Left : Unbounded_Integer; Right : Unbounded_Integer) return Unbounded_Integer; 18 -- Least common multiple; signs are ignored 19 20 procedure Simplify (Value : in out Rational); 21 -- Changes Value to have the smallest (absolute) values that represent the same rational number 22 -- 2/4 becomes 1/2 23 24 function Compose 25 (Numerator : PragmARC.Unbounded_Integers.Unbounded_Integer; Denominator : PragmARC.Unbounded_Integers.Unbounded_Integer) 26 return Rational is 27 Result : Rational := (Numerator => Numerator, Denominator => Denominator); 28 begin -- Compose 29 if Numerator < UI0 then 30 if Denominator < UI0 then 31 Result := (Numerator => abs Numerator, Denominator => abs Denominator); 32 end if; 33 -- Else signs are OK 34 elsif Denominator < UI0 then 35 if Numerator > UI0 then 36 Result := (Numerator => -Numerator, Denominator => abs Denominator); 37 end if; 38 -- Else Numerator is zero and Simplify will adjust the denominator 39 else 40 null; -- Signs are OK 41 end if; 42 43 Simplify (Value => Result); 44 45 return Result; 46 end Compose; 47 48 procedure Decompose (Value : in Rational; 49 Numerator : out PragmARC.Unbounded_Integers.Unbounded_Integer; 50 Denominator : out PragmARC.Unbounded_Integers.Unbounded_Integer) 51 is 52 -- Empty declarative part 53 begin -- Decompose 54 Numerator := Value.Numerator; 55 Denominator := Value.Denominator; 56 end Decompose; 57 58 function "+" (Right : Rational) return Rational is 59 -- Empty declarative part 60 begin -- "+" 61 return Right; 62 end "+"; 63 64 function "-" (Right : Rational) return Rational is 65 -- Empty declarative part 66 begin -- "-" 67 return (Numerator => -Right.Numerator, Denominator => Right.Denominator); 68 end "-"; 69 70 function "abs" (Right : Rational) return Rational is 71 -- Empty declarative part 72 begin -- "abs" 73 return (Numerator => abs Right.Numerator, Denominator => Right.Denominator); 74 end "abs"; 75 76 function "+" (Left : Rational; Right : Rational) return Rational is 77 M : Unbounded_Integer; 78 LN : Unbounded_Integer; 79 RN : Unbounded_Integer; 80 begin -- "+" 81 if Left.Denominator = Right.Denominator then 82 return Compose (Left.Numerator + Right.Numerator, Left.Denominator); 83 end if; 84 85 M := LCM (Left.Denominator, Right.Denominator); 86 LN := Left.Numerator * M / Left.Denominator; 87 RN := Right.Numerator * M / Right.Denominator; 88 89 return Compose (LN + RN, M); 90 end "+"; 91 92 function "-" (Left : Rational; Right : Rational) return Rational is 93 -- Empty declarative part 94 begin -- "-" 95 return Left + (-Right); 96 end "-"; 97 98 function "*" (Left : Rational; Right : Rational) return Rational is 99 -- Empty declarative part 100 begin -- "*" 101 return Compose (Left.Numerator * Right.Numerator, Left.Denominator * Right.Denominator); 102 end "*"; 103 104 function "/" (Left : Rational; Right : Rational) return Rational is 105 -- Empty declarative part 106 begin -- "/" 107 if Right = Zero then 108 raise Constraint_Error with "Division by zero"; 109 end if; 110 111 if Right < Zero then 112 return Compose (Left.Numerator * (-Right.Denominator), Left.Denominator * (abs Right.Numerator) ); 113 end if; 114 115 return Compose (Left.Numerator * Right.Denominator, Left.Denominator * Right.Numerator); 116 end "/"; 117 118 function "**" (Left : Rational; Right : Natural) return Rational is 119 Result : Rational := Left; 120 Work : Rational := Left; 121 begin -- "**"` 122 if Right = 0 then 123 return One; 124 end if; 125 126 if Right = 1 then 127 return Left; 128 end if; 129 130 if Left = Zero then 131 return Zero; 132 end if; 133 134 Calculate : declare -- This is O(log Right) 135 Power : Natural := Right - 1; 136 begin -- Calculate 137 Multiply : loop 138 exit Multiply when Power = 0; 139 140 if Power rem 2 = 0 then -- X ** (2 * P) = (X ** 2) ** P 141 Work := Work * Work; 142 Power := Power / 2; 143 else 144 Result := Work * Result; 145 Power := Power - 1; 146 end if; 147 end loop Multiply; 148 end Calculate; 149 150 return Result; 151 end "**"; 152 153 function ">" (Left : Rational; Right : Rational) return Boolean is 154 M : Unbounded_Integer; 155 begin -- ">" 156 if Left.Denominator = Right.Denominator then 157 return Left.Numerator > Right.Numerator; 158 end if; 159 160 if Left.Numerator < UI0 then 161 if Right.Numerator >= UI0 then 162 return False; 163 end if; 164 elsif Right.Numerator < UI0 then 165 return True; 166 else 167 null; 168 end if; 169 170 -- Signs are the same 171 172 M := LCM (Left.Denominator, Right.Denominator); 173 174 return Unbounded_Integer'(Left.Numerator * M / Left.Denominator) > Right.Numerator * M / Right.Denominator; 175 end ">"; 176 177 function "<" (Left : Rational; Right : Rational) return Boolean is 178 -- Empty declarative part 179 begin -- "<" 180 return Right > Left; 181 end "<"; 182 183 function ">=" (Left : Rational; Right : Rational) return Boolean is 184 -- Empty declarative part 185 begin -- ">=" 186 return not (Right > Left); 187 end ">="; 188 189 function "<=" (Left : Rational; Right : Rational) return Boolean is 190 -- Empty declarative part 191 begin -- "<=" 192 return not (Left > Right); 193 end "<="; 194 195 function Image (Value : Rational; As_Fraction : Boolean := False; Base : Base_Number := 10; Decorated : Boolean := False) 196 return String is 197 Ten : constant Unbounded_Integer := To_Unbounded_Integer (10); 198 199 Work : Unbounded_Integer := abs Value.Numerator; 200 Q : Unbounded_Integer; 201 Result : Ada.Strings.Unbounded.Unbounded_String; 202 203 use Ada.Strings.Unbounded; 204 begin -- Image 205 if As_Fraction then 206 return Image (Value.Numerator, Unbounded_Integers.Base_Number (Base), Decorated) & '/' & 207 Image (Value.Denominator, Unbounded_Integers.Base_Number (Base), Decorated); 208 end if; 209 210 if Value.Numerator < UI0 then 211 Append (Source => Result, New_Item => '-'); 212 end if; 213 214 Q := Work / Value.Denominator; 215 216 Append (Source => Result, New_Item => Image (Q) & '.'); 217 218 Work := Work - Q * Value.Denominator; 219 220 if Work = UI0 then 221 return To_String (Result) & '0'; 222 end if; 223 224 Zeros : loop 225 exit Zeros when Q /= UI0; 226 227 Work := Ten * Work; 228 Q := Work / Value.Denominator; 229 Append (Source => Result, New_Item => Image (Q) ); 230 Work := Work - Q * Value.Denominator; 231 end loop Zeros; 232 233 Count : for I in 1 .. 1_000 loop 234 exit Count when Work = UI0; 235 236 Work := Ten * Work; 237 Q := Work / Value.Denominator; 238 Append (Source => Result, New_Item => Image (Q) ); 239 Work := Work - Q * Value.Denominator; 240 end loop Count; 241 242 return To_String (Result); 243 end Image; 244 245 function Value (Image : String) return Rational is 246 Slash : constant Natural := Ada.Strings.Fixed.Index (Image, "/"); 247 Dot : constant Natural := Ada.Strings.Fixed.Index (Image, "."); 248 Hash : constant Natural := Ada.Strings.Fixed.Index (Image, "#"); 249 250 Result : Rational; 251 begin -- Value 252 if Slash > 0 then 253 return Compose (Value (Image (Image'First .. Slash - 1) ), Value (Image (Slash + 1 .. Image'Last) ) ); 254 end if; 255 256 if Dot = 0 then 257 return (Numerator => Value (Image), Denominator => UI1); 258 end if; 259 260 if Dot = Image'Last then 261 return (Numerator => Value (Image (Image'First .. Image'Last - 1) ), Denominator => UI1); 262 end if; 263 264 if Hash = 0 then 265 return Compose (Value (Image (Image'First .. Dot - 1) & Image (Dot + 1 .. Image'Last) ), 266 Value ('1' & (1 .. Image'Last - Dot => '0') ) ); 267 end if; 268 269 return Compose (Value (Image (Image'First .. Dot - 1) & Image (Dot + 1 .. Image'Last) ), 270 Value (Image (Image'First .. Hash) & '1' & (1 .. Image'Last - Dot - 1 => '0') & '#') ); 271 end Value; 272 273 function GCD (Left : Unbounded_Integer; Right : Unbounded_Integer) return Unbounded_Integer is 274 Min : Unbounded_Integer := abs Left; 275 Max : Unbounded_Integer := abs Right; 276 Remainder : Unbounded_Integer; 277 begin -- GCD 278 if Max < Min then 279 Remainder := Min; 280 Min := Max; 281 Max := Remainder; 282 end if; -- Now Min <= Max 283 284 Reduce : loop 285 if Min <= UI0 then 286 return Max; 287 end if; 288 289 Remainder := Max rem Min; 290 Max := Min; 291 Min := Remainder; 292 end loop Reduce; 293 end GCD; 294 295 function LCM (Left : Unbounded_Integer; Right : Unbounded_Integer) return Unbounded_Integer is 296 -- Empty declarative part 297 begin -- LCM 298 return (abs Left * (abs Right) ) / GCD (Left, Right); 299 end LCM; 300 301 procedure Simplify (Value : in out Rational) is 302 D : Unbounded_Integer; 303 begin -- Simplify 304 if Value.Numerator = UI0 then 305 if Value.Denominator = UI0 then 306 raise Constraint_Error with "Division by zero"; 307 end if; 308 309 Value := Zero; 310 311 return; 312 end if; 313 314 D := GCD (Value.Numerator, Value.Denominator); 315 316 Value := (Numerator => Value.Numerator / D, Denominator => Value.Denominator / D); 317 end Simplify; 318end PragmARC.Rational_Numbers; 319-- 320-- This is free software; you can redistribute it and/or modify it under 321-- terms of the GNU General Public License as published by the Free Software 322-- Foundation; either version 2, or (at your option) any later version. 323-- This software is distributed in the hope that it will be useful, but WITH 324-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY 325-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License 326-- for more details. Free Software Foundation, 59 Temple Place - Suite 327-- 330, Boston, MA 02111-1307, USA. 328-- 329-- As a special exception, if other files instantiate generics from this 330-- unit, or you link this unit with other files to produce an executable, 331-- this unit does not by itself cause the resulting executable to be 332-- covered by the GNU General Public License. This exception does not 333-- however invalidate any other reasons why the executable file might be 334-- covered by the GNU Public License. 335