home *** CD-ROM | disk | FTP | other *** search
/ Best Objectech Shareware Selections / UNTITLED.iso / boss / educ / math / 014 / pfloat.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-04-27  |  12.8 KB  |  281 lines
  1. UNIT pfloat;
  2. { *** Procedures for calculation with mfloat numbers *** }
  3.  
  4. INTERFACE
  5.  
  6. {$F+}
  7.  
  8. {----------------------------------------------------------------------------}
  9. { mfloat types }
  10. {----------------------------------------------------------------------------}
  11.  
  12. CONST MfloatWords = 16;
  13. TYPE  mfloat = ARRAY[0..MfloatWords-1] OF integer;
  14.  
  15. {----------------------------------------------------------------------------}
  16. { mfloat basic functions }
  17. {----------------------------------------------------------------------------}
  18.  
  19. PROCEDURE SetMantissawords(number : integer);
  20. FUNCTION  GetMantissawords : integer;
  21. PROCEDURE ResetError;
  22. FUNCTION  GetError : boolean;
  23.  
  24. PROCEDURE equm(   VAR a, b : mfloat);           { *** a <-- b            *** }
  25. PROCEDURE addm(   VAR a, b : mfloat);           { *** a <-- a + b        *** }
  26. PROCEDURE subm(   VAR a, b : mfloat);           { *** a <-- a - b        *** }
  27. PROCEDURE multm(  VAR a, b : mfloat);           { *** a <-- a * b        *** }
  28. PROCEDURE divm(   VAR a, b : mfloat);           { *** a <-- a / b        *** }
  29. PROCEDURE multi(  VAR a : mfloat; b : integer); { *** a <-- a * b        *** }
  30. PROCEDURE divi(   VAR a : mfloat; b : integer); { *** a <-- a / b        *** }
  31. PROCEDURE inversm(VAR a : mfloat);              { *** a <-- 1 / a        *** }
  32. PROCEDURE negm(   VAR a : mfloat);              { *** a <-  - a          *** }
  33. FUNCTION  eqZero( VAR a : mfloat) : boolean;    { *** eqZero <-- a = 0   *** }
  34. FUNCTION  gtZero( VAR a : mfloat) : boolean;    { *** gtZero <-- a > 0   *** }
  35. FUNCTION  geZero( VAR a : mfloat) : boolean;    { *** geZero <-- a >= 0  *** }
  36. FUNCTION  gtm(    VAR a, b : mfloat) : boolean; { *** gtm <-- a > b      *** }
  37. FUNCTION  eqm(    VAR a, b : mfloat) : boolean; { *** eqm <-- a = b      *** }
  38. PROCEDURE GetZerom(VAR a : mfloat);             { *** a <- 0             *** }
  39. PROCEDURE GetOnem(VAR a : mfloat);              { *** a <- 1             *** }
  40. PROCEDURE GetPim( VAR a : mfloat);              { *** a <- pi            *** }
  41. PROCEDURE GetLn2m(VAR a : mfloat);              { *** a <- ln(2)         *** }
  42. PROCEDURE GetLn10m(VAR a : mfloat);             { *** a <- ln(10)        *** }
  43. FUNCTION  strtomf(VAR a : mfloat;               { *** a <-- string       *** }
  44.                       b : string)
  45.                         : integer;
  46. FUNCTION  mftoa(  VAR a : mfloat;               { *** string <-- a       *** }
  47.                       len : integer)            { !!! compare with C         }
  48.                           : string;
  49. FUNCTION  mftostr(VAR a : mfloat;               { *** string <-- a       *** }
  50.                       len : integer;            { !!! compare with C         }
  51.                       format : string)
  52.                           : string;
  53. FUNCTION  MfToD(  VAR a : mfloat) : double;     { *** MfToD <- a         *** }
  54. FUNCTION  MfToLd( VAR a : mfloat) : extended;   { *** MfToLd <- a        *** }
  55. PROCEDURE DToMf(  VAR a : mfloat; b : double);  { *** a <- b             *** }
  56. PROCEDURE LdToMf( VAR a : mfloat; b : extended);{ *** a <- b             *** }
  57.  
  58. {----------------------------------------------------------------------------}
  59. { standard functions (Borland C: MATH.H) }
  60. {----------------------------------------------------------------------------}
  61.  
  62. PROCEDURE acosm(  VAR a : mfloat);              { *** a <- arccos(a)     *** }
  63. PROCEDURE asinm(  VAR a : mfloat);              { *** a <- arcsin(a)     *** }
  64. PROCEDURE atanm(  VAR a : mfloat);              { *** a <- arctan(a)     *** }
  65. PROCEDURE atan2m( VAR a, b : mfloat);           { *** a <- atan2(a, b)   *** }
  66. {         atof                                        see strtomf            }
  67. PROCEDURE ceilm(  VAR a : mfloat);              { *** a <-- ceil(a)      *** }
  68. PROCEDURE cosm(   VAR a : mfloat);              { *** a <- cos(a)        *** }
  69. PROCEDURE coshm(  VAR a : mfloat);              { *** a <- cosh(a)       *** }
  70. PROCEDURE expm(   VAR a : mfloat);              { *** a <- exp(a)        *** }
  71. PROCEDURE fabsm(  VAR a : mfloat);              { *** a <-- fabs(a)      *** }
  72. PROCEDURE floorm( VAR a : mfloat);              { *** a <-- floor(a)     *** }
  73. PROCEDURE fmodm(  VAR a, b : mfloat);           { *** a <- fmod(a,b)     *** }
  74. PROCEDURE frexpm( VAR a : mfloat;
  75.                   VAR b : integer);             { *** a <- frexp(a,b)    *** }
  76. PROCEDURE hypotm( VAR a, b : mfloat);           { *** a <- hypot(a,b)    *** }
  77. PROCEDURE ldexpm( VAR a : mfloat; b : integer); { *** a <- ldexp(a,b)    *** }
  78. PROCEDURE logm(   VAR a : mfloat);              { *** a <- ln(a)         *** }
  79. PROCEDURE log10m( VAR a : mfloat);              { *** a <- log10(a)      *** }
  80. PROCEDURE modfm(  VAR a, b : mfloat);           { *** a, b <- modf(a)    *** }
  81. PROCEDURE powm(   VAR a, b : mfloat);           { *** a <- a**b          *** }
  82. PROCEDURE pow10m( VAR a : mfloat; b : integer); { *** a <- 10**b         *** }
  83. PROCEDURE sinm(   VAR a : mfloat);              { *** a <- sin(a)        *** }
  84. PROCEDURE sinhm(  VAR a : mfloat);              { *** a <- sinh(a)       *** }
  85. PROCEDURE sqrtm(  VAR a : mfloat);              { *** a <- sqrt(a)       *** }
  86. PROCEDURE tanm(   VAR a : mfloat);              { *** a <- tan(a)        *** }
  87. PROCEDURE tanhm(  VAR a : mfloat);              { *** a <- tanh(a)       *** }
  88.  
  89. {----------------------------------------------------------------------------}
  90. { extended standard functions }
  91. {----------------------------------------------------------------------------}
  92.  
  93. PROCEDURE acoshm( VAR a : mfloat);              { *** a <- arcosh(a)     *** }
  94. PROCEDURE acotm(  VAR a : mfloat);              { *** a <- arccot(a)     *** }
  95. PROCEDURE acothm( VAR a : mfloat);              { *** a <- arcoth(a)     *** }
  96. PROCEDURE asinhm( VAR a : mfloat);              { *** a <- arsinh(a)     *** }
  97. PROCEDURE atanhm( VAR a : mfloat);              { *** a <- artanh(a)     *** }
  98. PROCEDURE cossinm(VAR a,b : mfloat);      { *** a <- cos(a), b <- sin(a) *** }
  99. PROCEDURE cotm(   VAR a : mfloat);              { *** a <- cot(a)        *** }
  100. PROCEDURE cothm(  VAR a : mfloat);              { *** a <- coth(a)       *** }
  101. PROCEDURE exp10m( VAR a : mfloat);              { *** a <- 10 ** a       *** }
  102. PROCEDURE sqrm(   VAR a : mfloat);              { *** a <- sqr(a)        *** }
  103. PROCEDURE truncm( VAR a : mfloat);              { *** a <-- trunc(a)     *** }
  104.  
  105. {----------------------------------------------------------------------------}
  106.  
  107. IMPLEMENTATION
  108.  
  109. {$L mfloata.obj}
  110. {$L mfloatb.obj}
  111.  
  112. {----------------------------------------------------------------------------}
  113. { initialized static variables }
  114. {----------------------------------------------------------------------------}
  115.  
  116. const
  117.   mantissawords    : integer = MfloatWords-1;
  118.   calculationerror : boolean = false;
  119.  
  120. {----------------------------------------------------------------------------}
  121. { externals }
  122. {----------------------------------------------------------------------------}
  123.  
  124. { mfloat basic functions }
  125. PROCEDURE SetMantissawords(number : integer);   external;
  126. FUNCTION  GetMantissawords : integer;           external;
  127. PROCEDURE ResetError;                           external;
  128. FUNCTION  GetError : boolean;                   external;
  129. PROCEDURE equm(   VAR a, b : mfloat);           external;
  130. PROCEDURE addm(   VAR a, b : mfloat);           external;
  131. PROCEDURE subm(   VAR a, b : mfloat);           external;
  132. PROCEDURE multm(  VAR a, b : mfloat);           external;
  133. PROCEDURE divm(   VAR a, b : mfloat);           external;
  134. PROCEDURE multi(  VAR a : mfloat; b : integer); external;
  135. PROCEDURE divi(   VAR a : mfloat; b : integer); external;
  136. PROCEDURE inversm(VAR a : mfloat);              external;
  137. PROCEDURE negm(   VAR a : mfloat);              external;
  138. FUNCTION  eqZero( VAR a : mfloat) : boolean;    external;
  139. FUNCTION  gtZero( VAR a : mfloat) : boolean;    external;
  140. FUNCTION  geZero( VAR a : mfloat) : boolean;    external;
  141. FUNCTION  gtm(    VAR a, b : mfloat) : boolean; external;
  142. FUNCTION  eqm(    VAR a, b : mfloat) : boolean; external;
  143. PROCEDURE GetZerom(VAR a : mfloat);             external;
  144. PROCEDURE GetOnem(VAR a : mfloat);              external;
  145. PROCEDURE GetPim( VAR a : mfloat);              external;
  146. PROCEDURE GetLn2m(VAR a : mfloat);              external;
  147. PROCEDURE GetLn10m(VAR a : mfloat);             external;
  148. PROCEDURE DToMf(  VAR a : mfloat; b : double);  external;
  149. PROCEDURE LdToMf( VAR a : mfloat; b : extended);external;
  150. { standard functions }
  151. PROCEDURE acosm(  VAR a : mfloat);              external;
  152. PROCEDURE asinm(  VAR a : mfloat);              external;
  153. PROCEDURE atanm(  VAR a : mfloat);              external;
  154. PROCEDURE atan2m( VAR a, b : mfloat);           external;
  155. PROCEDURE ceilm(  VAR a : mfloat);              external;
  156. PROCEDURE cosm(   VAR a : mfloat);              external;
  157. PROCEDURE coshm(  VAR a : mfloat);              external;
  158. PROCEDURE expm(   VAR a : mfloat);              external;
  159. PROCEDURE fabsm(  VAR a : mfloat);              external;
  160. PROCEDURE floorm( VAR a : mfloat);              external;
  161. PROCEDURE fmodm(  VAR a, b : mfloat);           external;
  162. PROCEDURE frexpm( VAR a : mfloat;
  163.                   VAR b : integer);             external;
  164. PROCEDURE hypotm( VAR a, b : mfloat);           external;
  165. PROCEDURE ldexpm( VAR a : mfloat; b : integer); external;
  166. PROCEDURE logm(   VAR a : mfloat);              external;
  167. PROCEDURE log10m( VAR a : mfloat);              external;
  168. PROCEDURE modfm(  VAR a, b : mfloat);           external;
  169. PROCEDURE powm(   VAR a, b : mfloat);           external;
  170. PROCEDURE pow10m( VAR a : mfloat; b : integer); external;
  171. PROCEDURE sinm(   VAR a : mfloat);              external;
  172. PROCEDURE sinhm(  VAR a : mfloat);              external;
  173. PROCEDURE sqrtm(  VAR a : mfloat);              external;
  174. PROCEDURE tanm(   VAR a : mfloat);              external;
  175. PROCEDURE tanhm(  VAR a : mfloat);              external;
  176. { extended standard functions }
  177. PROCEDURE acoshm( VAR a : mfloat);              external;
  178. PROCEDURE acotm(  VAR a : mfloat);              external;
  179. PROCEDURE acothm( VAR a : mfloat);              external;
  180. PROCEDURE asinhm( VAR a : mfloat);              external;
  181. PROCEDURE atanhm( VAR a : mfloat);              external;
  182. PROCEDURE cossinm(VAR a,b : mfloat);            external;
  183. PROCEDURE cotm(   VAR a : mfloat);              external;
  184. PROCEDURE cothm(  VAR a : mfloat);              external;
  185. PROCEDURE exp10m( VAR a : mfloat);              external;
  186. PROCEDURE sqrm(   VAR a : mfloat);              external;
  187. PROCEDURE truncm( VAR a : mfloat);              external;
  188. { internal functions }
  189. PROCEDURE SetMantissawords_(number : integer);  external;
  190. PROCEDURE mftostr_(VAR str;
  191.                   VAR a : mfloat;
  192.                   VAR len : integer;
  193.                   VAR format);                  external;
  194. FUNCTION strtomf_(VAR a : mfloat;
  195.                   VAR b;
  196.                   len : integer) : integer;     external;
  197. PROCEDURE MfToD_( VAR a : double; VAR b : mfloat);  external;
  198. PROCEDURE MfToLd_(VAR a : extended; VAR b : mfloat);external;
  199.  
  200. {----------------------------------------------------------------------------}
  201.  
  202. PROCEDURE SetMantissawords(number : integer);
  203.  
  204. begin
  205.   if number > MfloatWords-1 then
  206.     number := MfloatWords-1;
  207.   SetMantissawords_(number);
  208. end;
  209.  
  210. {----------------------------------------------------------------------------}
  211.  
  212. FUNCTION  strtomf(VAR a : mfloat;
  213.                       b : string)
  214.                         : integer;
  215.  
  216. begin
  217.   strtomf := strtomf_(a,b[1],ord(b[0]));
  218. end;
  219.  
  220. {----------------------------------------------------------------------------}
  221.  
  222. FUNCTION  mftoa(  VAR a : mfloat;               { *** string <-- a *** }
  223.                       len : integer)            { !!! compare with C }
  224.                           : string;
  225.  
  226. const format : string[8] = '.32767F'+#0;
  227. var tmp : string;
  228.  
  229. begin
  230.   if len > 255 then len := 255;
  231.   mftostr_(tmp[1],a,len,format[1]);
  232.   tmp[0] := chr(len);
  233.   mftoa := tmp;
  234. end;
  235.  
  236. {----------------------------------------------------------------------------}
  237.  
  238. FUNCTION  mftostr(VAR a : mfloat;
  239.                       len : integer;
  240.                       format : string)
  241.                           : string;
  242.  
  243. var tmp : string;
  244.  
  245. begin
  246.   if len > 255 then len := 255;
  247.   if length(format) = 255 then format[255] := #0
  248.   else format[length(format)+1] := #0;
  249.   mftostr_(tmp[1],a,len,format[1]);
  250.   tmp[0] := chr(len);
  251.   mftostr := tmp;
  252. end;
  253.  
  254. {----------------------------------------------------------------------------}
  255.  
  256. FUNCTION  MfToD(  VAR a : mfloat) : double;
  257.  
  258. var
  259.   tmp : double;
  260.  
  261. begin
  262.   MfToD_(tmp,a);
  263.   MfToD := tmp;
  264. end;
  265.  
  266. {----------------------------------------------------------------------------}
  267.  
  268. FUNCTION  MfToLd( VAR a : mfloat) : extended;   { *** MfToLd <- a *** }
  269.  
  270. var
  271.   tmp : extended;
  272.  
  273. begin
  274.   MfToLd_(tmp,a);
  275.   MfToLd := tmp;
  276. end;
  277.  
  278. {----------------------------------------------------------------------------}
  279.  
  280. end.
  281.