Annotation of OpenXM_contrib/PHC/Ada/Math_Lib/Numbers/ts_fltnum.adb, Revision 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>