Annotation of OpenXM_contrib/PHC/Ada/Math_Lib/Numbers/ts_fltnum.adb, Revision 1.1.1.1
1.1 maekawa 1: with text_io,integer_io; use text_io,integer_io;
2: with Multprec_Natural_Numbers; use Multprec_Natural_Numbers;
3: with Multprec_Natural_Numbers_io; use Multprec_Natural_Numbers_io;
4: with Multprec_Integer_Numbers; use Multprec_Integer_Numbers;
5: with Multprec_Integer_Numbers_io; use Multprec_Integer_Numbers_io;
6: with Standard_Floating_Numbers; use Standard_Floating_Numbers;
7: with Standard_Floating_Numbers_io; use Standard_Floating_Numbers_io;
8: with Standard_Mathematical_Functions; use Standard_Mathematical_Functions;
9: with Multprec_Floating_Numbers; use Multprec_Floating_Numbers;
10: with Multprec_Floating_Numbers_io; use Multprec_Floating_Numbers_io;
11: with Standard_Random_Numbers; use Standard_Random_Numbers;
12: with Multprec_Random_Numbers; use Multprec_Random_Numbers;
13:
14: procedure ts_fltnum is
15:
16: tol : constant double_float := 10.0**(-8);
17:
18: procedure Read ( f : in out Floating_Number; name : in string ) is
19:
20: n : natural;
21:
22: begin
23: put("Give " & name & " : "); get(f);
24: put("Current size is "); put(Size_Fraction(f),1);
25: put(". Give expansion factor : "); get(n);
26: if n > 0
27: then Expand(f,n);
28: end if;
29: end Read;
30:
31: procedure Formatted_Output ( f : in Floating_Number ) is
32:
33: -- DESCRIPTION :
34: -- Reads the format parameters and writes the floating-point number
35: -- accordingly.
36:
37: fore,aft,exp : natural;
38:
39: begin
40: put("Give the number of places before the decimal point : "); get(fore);
41: put("Give the number of places after the decimal point : "); get(aft);
42: put("Give the number of places of the exponent : "); get(exp);
43: put("-> formatted : "); put(f,fore,aft,exp); new_line;
44: end Formatted_Output;
45:
46: procedure Test_io is
47:
48: -- DESCRIPTION :
49: -- Reads and writes a floating-point number.
50:
51: f,abf : Floating_Number;
52: ans : character;
53:
54: begin
55: put_line("Testing input/output for multi-precision floating numbers.");
56: loop
57: put("Give a floating number : "); get(f);
58: put("-> your floating : "); put(f); new_line;
59: abf := AbsVal(f);
60: put("-> its absolute value : "); put(abf); new_line;
61: put("-> #decimal places in fraction : ");
62: put(Decimal_Places_Fraction(f),1); new_line;
63: put("-> #decimal places in exponent : ");
64: put(Decimal_Places_Exponent(f),1); new_line;
65: put("Do you want formatted output ? (y/n) "); get(ans);
66: if ans = 'y'
67: then Formatted_Output(f);
68: end if;
69: Clear(f); Clear(abf);
70: put("Do you want more tests ? (y/n) "); get(ans);
71: exit when (ans /= 'y');
72: end loop;
73: end Test_io;
74:
75: function Truncate ( f : in double_float ) return integer is
76:
77: i : integer := integer(f);
78:
79: begin
80: if i >= 0
81: then if double_float(i) > f + tol
82: then i := i-1;
83: end if;
84: else if double_float(i) < f - tol
85: then i := i+1;
86: end if;
87: end if;
88: return i;
89: end Truncate;
90:
91: procedure Test_Creation is
92:
93: f : Floating_Number;
94: d,fd : double_float;
95: i : integer;
96: ans : character;
97:
98: begin
99: put_line("Testing the creation of multi-precision floating numbers.");
100: loop
101: put("Give an integer : "); get(i);
102: put("-> your integer : "); put(i,1); new_line;
103: f := Create(i);
104: put("-> as floating number : "); put(f); new_line;
105: put("Give a standard float : "); get(d);
106: put("-> your float : "); put(d); new_line;
107: f := Create(d);
108: put("-> as floating number : "); put(f); new_line;
109: fd := Round(f);
110: put("-> rounded as standard float : "); put(fd); new_line;
111: if d = fd
112: then put_line("Creation/Rounding test is successful.");
113: else put_line("Difference up to working precision ?");
114: put("d - Round(Create(d)) : "); put(f-fd); new_line;
115: end if;
116: put("Give a floating number : "); get(f);
117: put("-> your floating number : "); put(f); new_line;
118: d := Round(f);
119: put("-> rounded as float :"); put(d); new_line;
120: put("Do you want more tests ? (y/n) "); get(ans);
121: exit when (ans /= 'y');
122: end loop;
123: end Test_Creation;
124:
125: procedure Test_Compare ( f1 : in Floating_Number; f2 : in double_float ) is
126: begin
127: if Equal(f1,f2)
128: then put_line("The numbers are equal.");
129: else put_line("The numbers are different.");
130: end if;
131: if f1 < f2
132: then put_line("First number is less than second number.");
133: else put_line("First number is not less than second number.");
134: end if;
135: if f1 > f2
136: then put_line("First number is greater than second number.");
137: else put_line("First number is not greater than second number.");
138: end if;
139: end Test_Compare;
140:
141: procedure Test_Compare ( f1,f2 : in Floating_Number ) is
142: begin
143: if Equal(f1,f2)
144: then put_line("The numbers are equal.");
145: else put_line("The numbers are different.");
146: end if;
147: if f1 < f2
148: then put_line("First number is less than second number.");
149: else put_line("First number is not less than second number.");
150: end if;
151: if f1 > f2
152: then put_line("First number is greater than second number.");
153: else put_line("First number is not greater than second number.");
154: end if;
155: end Test_Compare;
156:
157: procedure Zero_Test ( f : in Floating_Number ) is
158: begin
159: if Equal(f,0.0)
160: then put_line(" equals zero.");
161: else put_line(" is different from zero.");
162: end if;
163: end Zero_Test;
164:
165: procedure Test_Comparison is
166:
167: f1,f2 : Floating_Number;
168: -- f2 : double_float;
169: ans : character;
170:
171: begin
172: put_line("Testing comparison/copying for multi-precision floats.");
173: loop
174: put("Give 1st number f1 : "); get(f1);
175: put(" f1 : "); put(f1);
176: Zero_Test(f1);
177: put("Give 2nd number f2 : "); get(f2);
178: put(" f2 : "); put(f2);
179: Zero_Test(f2);
180: Test_Compare(f1,f2);
181: -- Copy(f1,f2);
182: -- put_line("After copy :");
183: -- Test_Compare(f1,f2);
184: put("Do you want more tests ? (y/n) "); get(ans);
185: exit when ans /= 'y';
186: end loop;
187: end Test_Comparison;
188:
189: procedure Test_Size is
190:
191: f,mf : Floating_Number;
192: ans : character;
193: factor : integer;
194: rnd : boolean;
195:
196: begin
197: put_line("Testing trunc/round/expand for multi-precision floats");
198: loop
199: put("Give a floating number : "); get(f);
200: put("-> your floating : "); put(f); new_line;
201: put("The size of the fraction : "); put(Size_Fraction(f),1); new_line;
202: loop
203: put("Give size modificator : "); get(factor);
204: if factor <= 0
205: then put("Do you want to truncate or to round ? (t/r) "); get(ans);
206: rnd := (ans = 'r');
207: end if;
208: if factor > 0
209: then -- mf := Expand(f,factor);
210: Expand(f,factor);
211: put("expanded : "); put(f); -- put(mf);
212: new_line;
213: elsif factor < 0
214: then if rnd
215: then -- mf := Round(f,-factor);
216: Round(f,-factor); put("rounded : ");
217: else -- mf := Trunc(f,-factor);
218: Trunc(f,-factor); put("truncated : ");
219: end if;
220: put(f); -- put(mf);
221: new_line;
222: else if rnd
223: then -- mf := Round(f,factor);
224: Round(f,factor); put("rounded : ");
225: else -- mf := Trunc(f,factor);
226: Trunc(f,factor); put("truncated : ");
227: end if;
228: put(f); -- put(mf);
229: new_line;
230: -- mf := Expand(f,factor);
231: Expand(f,factor);
232: put("expanded : "); put(f); -- put(mf);
233: new_line;
234: end if;
235: put("Do you want other size modificators ? (y/n) "); get(ans);
236: exit when (ans /= 'y');
237: end loop;
238: put("Do you want more tests ? (y/n) "); get(ans);
239: exit when (ans /= 'y');
240: end loop;
241: end Test_Size;
242:
243: procedure Test_Addition is
244:
245: ans : character;
246: f1,f2,sum1,sum2 : Floating_Number;
247:
248: begin
249: put_line("Testing the addition operations.");
250: loop
251: Read(f1,"f1");
252: -- put("Give 1st number f1 : "); get(f1);
253: put("-> f1 : "); put(f1); new_line;
254: Read(f2,"f2");
255: -- put("Give 2nd number f2 : "); get(f2);
256: put("-> f2 : "); put(f2); new_line;
257: sum1 := f1+f2;
258: put("f1+f2 : "); put(sum1); new_line;
259: sum2 := f2+f1;
260: put("f2+f1 : "); put(sum2); new_line;
261: if Equal(sum1,sum2)
262: then put_line("Test on commutativity is successful.");
263: else put_line("Failure, bug detected.");
264: end if;
265: put("Do you want more tests ? (y/n) "); get(ans);
266: exit when ans /= 'y';
267: end loop;
268: end Test_Addition;
269:
270: procedure Test_Subtraction is
271:
272: ans : character;
273: f1,f2,diff : Floating_Number;
274:
275: begin
276: put_line("Testing the subtraction operations.");
277: loop
278: Read(f1,"f1");
279: -- put("Give 1st number f1 : "); get(f1);
280: put("-> f1 : "); put(f1); new_line;
281: Read(f2,"f2");
282: -- put("Give 2nd number f2 : "); get(f2);
283: put("-> f2 : "); put(f2); new_line;
284: diff := f1-f2;
285: put("f1 - f2 : "); put(diff); new_line;
286: Add(diff,f2);
287: put("(f1-f2)+f2 : "); put(diff); new_line;
288: if Equal(diff,f1)
289: then put_line("Test of subtraction is successful.");
290: else put_line("Failure, bug detected.");
291: end if;
292: put("Do you want more tests ? (y/n) "); get(ans);
293: exit when ans /= 'y';
294: end loop;
295: end Test_Subtraction;
296:
297: procedure Test_Multiplication is
298:
299: ans : character;
300: f1,f2,prod1,prod2 : Floating_Number;
301:
302: begin
303: put_line("Testing the multiplication operations.");
304: loop
305: Read(f1,"f1");
306: -- put("Give 1st number : "); get(f1);
307: put("-> f1 : "); put(f1); new_line;
308: Read(f2,"f2");
309: -- put("Give 2nd number : "); get(f2);
310: put("-> f2 : "); put(f2); new_line;
311: prod1 := f1*f2;
312: put("Product f1*f2 : "); put(prod1); new_line;
313: prod2 := f2*f1;
314: put("Product f2*f1 : "); put(prod2); new_line;
315: if Equal(prod1,prod2)
316: then put_line("Test on commutativity is successful.");
317: else put_line("Failure, product not commutative: bug!");
318: end if;
319: put("Do you want more tests ? (y/n) "); get(ans);
320: exit when ans /= 'y';
321: end loop;
322: end Test_Multiplication;
323:
324: procedure Test_Exponentiation is
325:
326: ans : character;
327: e1,e2 : Integer_Number;
328: f,exp1,exp2,prod,expo : Floating_Number;
329:
330: begin
331: put_line("Testing the exponentiation operations.");
332: loop
333: Read(f,"f");
334: -- put("Give a number : "); get(f);
335: put("-> your number f : "); put(f); new_line;
336: put("Give 1st exponent : "); get(e1);
337: put("-> your 1st exponent e1 : "); put(e1); new_line;
338: exp1 := f**e1;
339: put("f**e1 : "); put(exp1); new_line;
340: put("Give 2nd exponent : "); get(e2);
341: put("-> your 2nd exponent e2 : "); put(e2); new_line;
342: exp2 := f**e2;
343: put("f**e2 : "); put(exp2); new_line;
344: prod := exp1*exp2;
345: put("(f**e1)*(f**e2) : "); put(prod); new_line;
346: expo := f**(e1+e2);
347: put("f**(e1+e2) : "); put(expo); new_line;
348: if Equal(prod,expo)
349: then put_line("Test of exponentiation is successful.");
350: else put_line("Failure, bug detected.");
351: end if;
352: put("Do you want more tests ? (y/n) "); get(ans);
353: exit when ans /= 'y';
354: end loop;
355: end Test_Exponentiation;
356:
357: procedure Test_Division is
358:
359: ans : character;
360: f1,f2,quot,prod,diff : Floating_Number;
361:
362: begin
363: put_line("Testing the division operations.");
364: loop
365: Read(f1,"f1");
366: -- put("Give 1st number f1 : "); get(f1);
367: put("-> f1 : "); put(f1); new_line;
368: Read(f2,"f2");
369: -- put("Give 2nd number f2 : "); get(f2);
370: put("-> f2 : "); put(f2); new_line;
371: prod := f1*f2;
372: put("f1*f2 : "); put(prod); new_line;
373: quot := prod/f2;
374: put("(f1*f2)/f2 : "); put(quot); new_line;
375: if Equal(quot,f1)
376: then put_line("Test of division is successful.");
377: else put("Failure, bug detected?");
378: put_line(" Difference up to working precision?");
379: diff := quot - f1;
380: put("(f1*f2)/f2 - f1 : "); put(diff); new_line;
381: end if;
382: Copy(f1,quot);
383: Div(quot,f2); put("f1/f2 : "); put(quot); new_line;
384: prod := quot*f2; put("(f1/f2)*f2 : "); put(prod); new_line;
385: put(" f1 : "); put(f1); new_line;
386: if Equal(prod,f1)
387: then put_line("Test of division/remainder computation is successful.");
388: else put("Failure, bug detected?");
389: put_line(" Difference up to working precision?");
390: if prod > f1
391: then diff := prod - f1;
392: else diff := f1 - prod;
393: end if;
394: put("(f1/f2)*f2 - f1 : "); put(diff); new_line;
395: end if;
396: put("Do you want more tests ? (y/n) "); get(ans);
397: exit when ans /= 'y';
398: end loop;
399: end Test_Division;
400:
401: function Random ( sz : natural; low,upp : integer ) return Floating_Number is
402:
403: -- DESCRIPTION :
404: -- Generates a random number of the given size, with exponent between
405: -- the bounds low and upp.
406:
407: res : Floating_Number := Random(sz);
408: exp : integer := Random(low,upp);
409:
410: begin
411: if exp > 0
412: then for i in 1..exp loop
413: Mul(res,10.0);
414: end loop;
415: elsif exp < 0
416: then for i in 1..(-exp) loop
417: Div(res,10.0);
418: end loop;
419: end if;
420: return res;
421: end Random;
422:
423: procedure Random_Addition_and_Subtraction
424: ( sz1,sz2 : in natural; low,upp : in integer ) is
425:
426: -- DESCRIPTION :
427: -- Three tests are performed:
428: -- 1) n1+n2-n2 = n1, with "+" and "-".
429: -- 2) Add(n1,n2) is the same as n1 := n1+n2?
430: -- 3) Sub(n1+n2,n1) leads to n2?
431:
432: n1,n2,sum1,sum2,tmp : Floating_Number;
433:
434: procedure Report_Bug is
435: begin
436: new_line;
437: put(" n1 : "); put(n1); new_line;
438: put(" n2 : "); put(n2); new_line;
439: end Report_Bug;
440:
441: begin
442: n1 := Random(sz1,low,upp);
443: n2 := Random(sz2,low,upp);
444: sum1 := n1+n2;
445: sum2 := sum1-n2;
446: if Equal(sum2,n1)
447: then put("n1+n2-n2 okay");
448: else put("n1+n2-n2 Bug?"); Report_Bug;
449: put("diff : "); tmp := sum2-n1; put(tmp); new_line;
450: Clear(tmp);
451: end if;
452: Add(sum2,n2);
453: if Equal(sum2,sum1)
454: then put(" Add okay");
455: else put(" Add Bug?"); Report_Bug;
456: put("diff : "); tmp := sum2-sum1; put(tmp); new_line;
457: Clear(tmp);
458: end if;
459: Sub(sum2,n1);
460: if Equal(sum2,n2)
461: then put(" Sub okay"); new_line;
462: else put(" Sub Bug?"); Report_Bug;
463: put("diff : "); tmp := sum2-n2; put(tmp); new_line;
464: Clear(tmp);
465: end if;
466: Clear(n1); Clear(n2);
467: Clear(sum1); Clear(sum2);
468: exception
469: when others => put_line("input caused exception:"); Report_Bug; raise;
470: end Random_Addition_and_Subtraction;
471:
472: procedure Additions_and_Subtractions_on_Randoms is
473:
474: -- DESCRIPTION :
475: -- Generates a number of random floats and performs repeated
476: -- additions and subtractions with checks on consistencies.
477:
478: nb,sz1,sz2 : natural;
479: low,upp : integer;
480:
481: begin
482: put("Give the number of tests : "); get(nb);
483: put("Give the size of the 1st number : "); get(sz1);
484: put("Give the size of the 2nd number : "); get(sz2);
485: put("Give lower bound on exponent : "); get(low);
486: put("Give upper bound on exponent : "); get(upp);
487: for i in 1..nb loop
488: Random_Addition_and_Subtraction(sz1,sz2,low,upp);
489: end loop;
490: end Additions_and_Subtractions_on_Randoms;
491:
492: procedure Random_Multiplication_and_Division
493: ( sz1,sz2 : in natural; low,upp : in integer ) is
494:
495: -- DESCRIPTION :
496: -- Three tests are performed :
497: -- 1) n1*n2/n2 = n1, with "*" and "/".
498: -- 2) Mul(n1,n2) is the same as n1 := n1*n2 ?
499: -- 3) Div(n1*n2,n1) leads to n2 ?
500:
501: n1,n2,prod,quot,tmp : Floating_Number;
502:
503: procedure Report_Bug is
504: begin
505: new_line;
506: put(" n1 : "); put(n1); new_line;
507: put(" n2 : "); put(n2); new_line;
508: end Report_Bug;
509:
510: begin
511: n1 := Random(sz1,low,upp);
512: n2 := Random(sz2,low,upp);
513: prod := n1*n2;
514: quot := prod/n2;
515: if Equal(quot,n1)
516: then put("n1*n2/n2 okay");
517: else put("n1*n2/n2 Bug?"); Report_Bug;
518: put("Diff : "); tmp := quot-n1; put(tmp); new_line;
519: Clear(tmp);
520: end if;
521: Mul(quot,n2);
522: if Equal(prod,quot)
523: then put(" Mul okay");
524: else put(" Mul Bug?"); Report_Bug;
525: put("Diff : "); tmp := quot-prod; put(tmp); new_line;
526: Clear(tmp);
527: end if;
528: Div(prod,n1);
529: if Equal(prod,n2)
530: then put(" Div okay"); new_line;
531: else put(" Div Bug?"); Report_Bug;
532: put("Diff : "); tmp := prod-n2; put(tmp); new_line;
533: Clear(tmp);
534: end if;
535: Clear(n1); Clear(n2);
536: Clear(prod); Clear(quot);
537: exception
538: when others => put_line("input caused exception :"); Report_Bug; raise;
539: end Random_Multiplication_and_Division;
540:
541: procedure Multiplications_and_Divisions_on_Randoms is
542:
543: -- DESCRIPTION :
544: -- Generates a number of random floats and performs repeated
545: -- multiplications and divisions with checks on consistencies.
546:
547: nb,sz1,sz2 : natural;
548: low,upp : integer;
549:
550: begin
551: put("Give the number of tests : "); get(nb);
552: put("Give the size of the 1st number : "); get(sz1);
553: put("Give the size of the 2nd number : "); get(sz2);
554: put("Give lower bound on exponent : "); get(low);
555: put("Give upper bound on exponent : "); get(upp);
556: for i in 1..nb loop
557: Random_Multiplication_and_Division(sz1,sz2,low,upp);
558: end loop;
559: end Multiplications_and_Divisions_on_Randoms;
560:
561: procedure Main is
562:
563: ans : character;
564:
565: begin
566: new_line;
567: put_line("Interactive testing of multi-precision floating numbers.");
568: loop
569: new_line;
570: put_line("Choose one of the following : ");
571: put_line(" 0. exit program 1. Input/Output 2. Creation ");
572: put_line(" 3. Comparison/Copy 4. Addition 5. Subtraction ");
573: put_line(" 6. Multiplication 7. Exponentiation 8. Division ");
574: put_line(" 9. Truncate/Round/Expand ");
575: put_line(" A. Addition/subtraction on randomly generated numbers. ");
576: put_line(" B. Multiplication/division/remainder on random numbers. ");
577: put("Type in your choice (0,1,2,3,4,5,6,7,8,9,A, or B) : "); get(ans);
578: exit when (ans = '0');
579: new_line;
580: case ans is
581: when '1' => Test_io;
582: when '2' => Test_Creation;
583: when '3' => Test_Comparison;
584: when '4' => Test_Addition;
585: when '5' => Test_Subtraction;
586: when '6' => Test_Multiplication;
587: when '7' => Test_Exponentiation;
588: when '8' => Test_Division;
589: when '9' => Test_Size;
590: when 'A' => Additions_and_Subtractions_on_Randoms;
591: when 'B' => Multiplications_and_Divisions_on_Randoms;
592: when others => null;
593: end case;
594: end loop;
595: end Main;
596:
597: begin
598: Main;
599: end ts_fltnum;
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to ts_fltnum.adb CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib / PHC / Ada / Math_Lib / Numbers