1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT RUN-TIME COMPONENTS                         --
4--                                                                          --
5--                   ADA.NUMERICS.BIG_NUMBERS.BIG_REALS                     --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--             Copyright (C) 2019, Free Software Foundation, Inc.           --
10--                                                                          --
11-- GNAT is free software;  you can  redistribute it  and/or modify it under --
12-- terms of the  GNU General Public License as published  by the Free Soft- --
13-- ware  Foundation;  either version 3,  or (at your option) any later ver- --
14-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
15-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
16-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
17--                                                                          --
18-- As a special exception under Section 7 of GPL version 3, you are granted --
19-- additional permissions described in the GCC Runtime Library Exception,   --
20-- version 3.1, as published by the Free Software Foundation.               --
21--                                                                          --
22-- You should have received a copy of the GNU General Public License and    --
23-- a copy of the GCC Runtime Library Exception along with this program;     --
24-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
25-- <http://www.gnu.org/licenses/>.                                          --
26--                                                                          --
27-- GNAT was originally developed  by the GNAT team at  New York University. --
28-- Extensive contributions were provided by Ada Core Technologies Inc.      --
29--                                                                          --
30------------------------------------------------------------------------------
31
32--  This is the default version of this package, based on Big_Integers only.
33
34with Ada.Characters.Conversions; use Ada.Characters.Conversions;
35
36package body Ada.Numerics.Big_Numbers.Big_Reals is
37
38   use Big_Integers;
39
40   procedure Normalize (Arg : in out Big_Real);
41   --  Normalize Arg by ensuring that Arg.Den is always positive and that
42   --  Arg.Num and Arg.Den always have a GCD of 1.
43
44   --------------
45   -- Is_Valid --
46   --------------
47
48   function Is_Valid (Arg : Big_Real) return Boolean is
49     (Is_Valid (Arg.Num) and then Is_Valid (Arg.Den));
50
51   ---------
52   -- "/" --
53   ---------
54
55   function "/" (Num, Den : Big_Integer) return Big_Real is
56      Result : Big_Real;
57   begin
58      if Den = To_Big_Integer (0) then
59         raise Constraint_Error with "divide by zero";
60      end if;
61
62      Result.Num := Num;
63      Result.Den := Den;
64      Normalize (Result);
65      return Result;
66   end "/";
67
68   ---------------
69   -- Numerator --
70   ---------------
71
72   function Numerator (Arg : Big_Real) return Big_Integer is (Arg.Num);
73
74   -----------------
75   -- Denominator --
76   -----------------
77
78   function Denominator (Arg : Big_Real) return Big_Positive is (Arg.Den);
79
80   ---------
81   -- "=" --
82   ---------
83
84   function "=" (L, R : Big_Real) return Boolean is
85     (abs L.Num = abs R.Num and then L.Den = R.Den);
86
87   ---------
88   -- "<" --
89   ---------
90
91   function "<" (L, R : Big_Real) return Boolean is
92     (abs L.Num * R.Den < abs R.Num * L.Den);
93
94   ----------
95   -- "<=" --
96   ----------
97
98   function "<=" (L, R : Big_Real) return Boolean is (not (R < L));
99
100   ---------
101   -- ">" --
102   ---------
103
104   function ">" (L, R : Big_Real) return Boolean is (R < L);
105
106   ----------
107   -- ">=" --
108   ----------
109
110   function ">=" (L, R : Big_Real) return Boolean is (not (L < R));
111
112   -----------------------
113   -- Float_Conversions --
114   -----------------------
115
116   package body Float_Conversions is
117
118      -----------------
119      -- To_Big_Real --
120      -----------------
121
122      function To_Big_Real (Arg : Num) return Big_Real is
123      begin
124         return From_String (Arg'Image);
125      end To_Big_Real;
126
127      -------------------
128      -- From_Big_Real --
129      -------------------
130
131      function From_Big_Real (Arg : Big_Real) return Num is
132      begin
133         return Num'Value (To_String (Arg));
134      end From_Big_Real;
135
136   end Float_Conversions;
137
138   -----------------------
139   -- Fixed_Conversions --
140   -----------------------
141
142   package body Fixed_Conversions is
143
144      -----------------
145      -- To_Big_Real --
146      -----------------
147
148      function To_Big_Real (Arg : Num) return Big_Real is
149      begin
150         return From_String (Arg'Image);
151      end To_Big_Real;
152
153      -------------------
154      -- From_Big_Real --
155      -------------------
156
157      function From_Big_Real (Arg : Big_Real) return Num is
158      begin
159         return Num'Value (To_String (Arg));
160      end From_Big_Real;
161
162   end Fixed_Conversions;
163
164   ---------------
165   -- To_String --
166   ---------------
167
168   function To_String
169     (Arg : Big_Real; Fore : Field := 2; Aft : Field := 3; Exp : Field := 0)
170      return String
171   is
172      Zero : constant Big_Integer := To_Big_Integer (0);
173      Ten  : constant Big_Integer := To_Big_Integer (10);
174
175      function Leading_Padding
176        (Str        : String;
177         Min_Length : Field;
178         Char       : Character := ' ') return String;
179      --  Return padding of Char concatenated with Str so that the resulting
180      --  string is at least Min_Length long.
181
182      function Trailing_Padding
183        (Str    : String;
184         Length : Field;
185         Char   : Character := '0') return String;
186      --  Return Str with trailing Char removed, and if needed either
187      --  truncated or concatenated with padding of Char so that the resulting
188      --  string is Length long.
189
190      function Image (N : Natural) return String;
191      --  Return image of N, with no leading space.
192
193      function Numerator_Image
194        (Num   : Big_Integer;
195         After : Natural) return String;
196      --  Return image of Num as a float value with After digits after the "."
197      --  and taking Fore, Aft, Exp into account.
198
199      -----------
200      -- Image --
201      -----------
202
203      function Image (N : Natural) return String is
204         S : constant String := Natural'Image (N);
205      begin
206         return S (2 .. S'Last);
207      end Image;
208
209      ---------------------
210      -- Leading_Padding --
211      ---------------------
212
213      function Leading_Padding
214        (Str        : String;
215         Min_Length : Field;
216         Char       : Character := ' ') return String is
217      begin
218         if Str = "" then
219            return Leading_Padding ("0", Min_Length, Char);
220         else
221            return (1 .. Integer'Max (Integer (Min_Length) - Str'Length, 0)
222                           => Char) & Str;
223         end if;
224      end Leading_Padding;
225
226      ----------------------
227      -- Trailing_Padding --
228      ----------------------
229
230      function Trailing_Padding
231        (Str    : String;
232         Length : Field;
233         Char   : Character := '0') return String is
234      begin
235         if Str'Length > 0 and then Str (Str'Last) = Char then
236            for J in reverse Str'Range loop
237               if Str (J) /= '0' then
238                  return Trailing_Padding
239                    (Str (Str'First .. J), Length, Char);
240               end if;
241            end loop;
242         end if;
243
244         if Str'Length >= Length then
245            return Str (Str'First .. Str'First + Length - 1);
246         else
247            return Str &
248              (1 .. Integer'Max (Integer (Length) - Str'Length, 0)
249                      => Char);
250         end if;
251      end Trailing_Padding;
252
253      ---------------------
254      -- Numerator_Image --
255      ---------------------
256
257      function Numerator_Image
258        (Num   : Big_Integer;
259         After : Natural) return String
260      is
261         Tmp   : constant String := To_String (Num);
262         Str   : constant String (1 .. Tmp'Last - 1) := Tmp (2 .. Tmp'Last);
263         Index : Integer;
264
265      begin
266         if After = 0 then
267            return Leading_Padding (Str, Fore) & "."
268                   & Trailing_Padding ("0", Aft);
269         else
270            Index := Str'Last - After;
271
272            if Index < 0 then
273               return Leading_Padding ("0", Fore)
274                 & "."
275                 & Trailing_Padding ((1 .. -Index => '0') & Str, Aft)
276                 & (if Exp = 0 then "" else "E+" & Image (Natural (Exp)));
277            else
278               return Leading_Padding (Str (Str'First .. Index), Fore)
279                 & "."
280                 & Trailing_Padding (Str (Index + 1 .. Str'Last), Aft)
281                 & (if Exp = 0 then "" else "E+" & Image (Natural (Exp)));
282            end if;
283         end if;
284      end Numerator_Image;
285
286   begin
287      if Arg.Num < Zero then
288         declare
289            Str : String := To_String (-Arg, Fore, Aft, Exp);
290         begin
291            if Str (1) = ' ' then
292               for J in 1 .. Str'Last - 1 loop
293                  if Str (J + 1) /= ' ' then
294                     Str (J) := '-';
295                     exit;
296                  end if;
297               end loop;
298
299               return Str;
300            else
301               return '-' & Str;
302            end if;
303         end;
304      else
305         --  Compute Num * 10^Aft so that we get Aft significant digits
306         --  in the integer part (rounded) to display.
307
308         return Numerator_Image
309           ((Arg.Num * Ten ** Aft) / Arg.Den, After => Exp + Aft);
310      end if;
311   end To_String;
312
313   -----------------
314   -- From_String --
315   -----------------
316
317   function From_String (Arg : String) return Big_Real is
318      Ten   : constant Big_Integer := To_Big_Integer (10);
319      Frac  : Big_Integer;
320      Exp   : Integer := 0;
321      Pow   : Natural := 0;
322      Index : Natural := 0;
323      Last  : Natural := Arg'Last;
324
325   begin
326      for J in reverse Arg'Range loop
327         if Arg (J) in 'e' | 'E' then
328            if Last /= Arg'Last then
329               raise Constraint_Error with "multiple exponents specified";
330            end if;
331
332            Last := J - 1;
333            Exp := Integer'Value (Arg (J + 1 .. Arg'Last));
334            Pow := 0;
335
336         elsif Arg (J) = '.' then
337            Index := J - 1;
338            exit;
339         else
340            Pow := Pow + 1;
341         end if;
342      end loop;
343
344      if Index = 0 then
345         raise Constraint_Error with "invalid real value";
346      end if;
347
348      declare
349         Result : Big_Real;
350      begin
351         Result.Den := Ten ** Pow;
352         Result.Num := From_String (Arg (Arg'First .. Index)) * Result.Den;
353         Frac := From_String (Arg (Index + 2 .. Last));
354
355         if Result.Num < To_Big_Integer (0) then
356            Result.Num := Result.Num - Frac;
357         else
358            Result.Num := Result.Num + Frac;
359         end if;
360
361         if Exp > 0 then
362            Result.Num := Result.Num * Ten ** Exp;
363         elsif Exp < 0 then
364            Result.Den := Result.Den * Ten ** (-Exp);
365         end if;
366
367         Normalize (Result);
368         return Result;
369      end;
370   end From_String;
371
372   --------------------------
373   -- From_Quotient_String --
374   --------------------------
375
376   function From_Quotient_String (Arg : String) return Big_Real is
377      Index : Natural := 0;
378   begin
379      for J in Arg'First + 1 .. Arg'Last - 1 loop
380         if Arg (J) = '/' then
381            Index := J;
382            exit;
383         end if;
384      end loop;
385
386      if Index = 0 then
387         raise Constraint_Error with "no quotient found";
388      end if;
389
390      return Big_Integers.From_String (Arg (Arg'First .. Index - 1)) /
391        Big_Integers.From_String (Arg (Index + 1 .. Arg'Last));
392   end From_Quotient_String;
393
394   ---------------
395   -- Put_Image --
396   ---------------
397
398   procedure Put_Image
399     (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
400      Arg    : Big_Real) is
401   begin
402      Wide_Wide_String'Write (Stream, To_Wide_Wide_String (To_String (Arg)));
403   end Put_Image;
404
405   ---------
406   -- "+" --
407   ---------
408
409   function "+" (L : Big_Real) return Big_Real is
410      Result : Big_Real;
411   begin
412      Result.Num := L.Num;
413      Result.Den := L.Den;
414      return Result;
415   end "+";
416
417   ---------
418   -- "-" --
419   ---------
420
421   function "-" (L : Big_Real) return Big_Real is
422     (Num => -L.Num, Den => L.Den);
423
424   -----------
425   -- "abs" --
426   -----------
427
428   function "abs" (L : Big_Real) return Big_Real is
429     (Num => abs L.Num, Den => L.Den);
430
431   ---------
432   -- "+" --
433   ---------
434
435   function "+" (L, R : Big_Real) return Big_Real is
436      Result : Big_Real;
437   begin
438      Result.Num := L.Num * R.Den + R.Num * L.Den;
439      Result.Den := L.Den * R.Den;
440      Normalize (Result);
441      return Result;
442   end "+";
443
444   ---------
445   -- "-" --
446   ---------
447
448   function "-" (L, R : Big_Real) return Big_Real is
449      Result : Big_Real;
450   begin
451      Result.Num := L.Num * R.Den - R.Num * L.Den;
452      Result.Den := L.Den * R.Den;
453      Normalize (Result);
454      return Result;
455   end "-";
456
457   ---------
458   -- "*" --
459   ---------
460
461   function "*" (L, R : Big_Real) return Big_Real is
462      Result : Big_Real;
463   begin
464      Result.Num := L.Num * R.Num;
465      Result.Den := L.Den * R.Den;
466      Normalize (Result);
467      return Result;
468   end "*";
469
470   ---------
471   -- "/" --
472   ---------
473
474   function "/" (L, R : Big_Real) return Big_Real is
475      Result : Big_Real;
476   begin
477      Result.Num := L.Num * R.Den;
478      Result.Den := L.Den * R.Num;
479      Normalize (Result);
480      return Result;
481   end "/";
482
483   ----------
484   -- "**" --
485   ----------
486
487   function "**" (L : Big_Real; R : Integer) return Big_Real is
488      Result : Big_Real;
489   begin
490      if R = 0 then
491         Result.Num := To_Big_Integer (1);
492         Result.Den := To_Big_Integer (1);
493      else
494         if R < 0 then
495            Result.Num := L.Den ** (-R);
496            Result.Den := L.Num ** (-R);
497         else
498            Result.Num := L.Num ** R;
499            Result.Den := L.Den ** R;
500         end if;
501
502         Normalize (Result);
503      end if;
504
505      return Result;
506   end "**";
507
508   ---------
509   -- Min --
510   ---------
511
512   function Min (L, R : Big_Real) return Big_Real is (if L < R then L else R);
513
514   ---------
515   -- Max --
516   ---------
517
518   function Max (L, R : Big_Real) return Big_Real is (if L > R then L else R);
519
520   ---------------
521   -- Normalize --
522   ---------------
523
524   procedure Normalize (Arg : in out Big_Real) is
525   begin
526      if Arg.Den < To_Big_Integer (0) then
527         Arg.Num := -Arg.Num;
528         Arg.Den := -Arg.Den;
529      end if;
530
531      declare
532         GCD : constant Big_Integer :=
533           Greatest_Common_Divisor (Arg.Num, Arg.Den);
534      begin
535         Arg.Num := Arg.Num / GCD;
536         Arg.Den := Arg.Den / GCD;
537      end;
538   end Normalize;
539
540end Ada.Numerics.Big_Numbers.Big_Reals;
541