home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / CALC / RPN30SRC.ZIP / FTNS.C < prev    next >
Encoding:
C/C++ Source or Header  |  1990-05-30  |  25.4 KB  |  976 lines
  1. /*
  2. | ftns.c - implementations of the calculator functions.  These are
  3. | called in process.c, either indirectly through funct_1() or directly.
  4. | Most of these functions have entries in one of the function tables.
  5. | Those that do not are kept at the end of the file, after funct_1().
  6. |
  7. | 90.05.28 v3.0
  8. |    "The rest" of the hyberbolic trig. functions, gamma/factorial,
  9. |    conversions, linear regression added.  More code moved from
  10. |    process.c; nullary-function lookup added (like unary functions).
  11. |    Lotsa code rearrangement between this and process.c
  12. | 90.01.01, local noon
  13. */
  14. #include <math.h>
  15. #include <float.h>    /* DBL_MAX definition */
  16. #include <string.h>    /* for strcmp() */
  17. #include <stdlib.h>
  18. #include "rpn.h"
  19. #include "display.h"    /** for prterr() prototype **/
  20. #define FTNS
  21. #include "ftns.h"
  22. #include"debug.h"
  23.  
  24. #define INT_PART(x)  floor( x )
  25. #define NULL  0
  26.  
  27.  
  28. /** / / / / / / / / / / / / / / / / / / / / / / / / / / / / / / / / / / / **
  29.  **
  30.  ** Okay to multiply?  y*x > MAXDOUBLE ?  y*x < MINDOUBLE ?
  31.  ** If underflow, the math library will just generate 0.0;
  32.  ** let that happen, but report it.
  33.  **/
  34. int mul_ok(double y, double x, char *caller)
  35. {
  36.     y = fabs(y);
  37.     x = fabs(x);
  38.     if (y > 1.0  &&  x > 1.0  &&  y > MAXDOUBLE / x) {
  39.         prterr(caller, "overflow");
  40.         return FALSE;
  41.     }
  42.     if (y < 1.0  &&  x < 1.0  &&  y < MINDOUBLE / x) {
  43.         prterr(caller, "underflow");
  44.     }
  45.     return TRUE;
  46. }
  47.  
  48. /**\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\**/
  49.  
  50. void shift_lastx(void)        /**-------------------------------------**/
  51. {                /** Stash & alter LastX register.    **/
  52.     tmpLX = lastx;        /** Utility ftn., called by various    **/
  53.     lastx = xreg;        /** function-implementing routines.    **/
  54. }                /**-------------------------------------**/
  55.  
  56.  
  57. /*---------------------------------------------------------------------*\
  58. | Convert "sexagesimal" (hh.mmssttt) formatted values to decimal-hour    |
  59. | format.  This is a real ugly pain, because base-10/base-2 conversion    |
  60. | errors make the minute and second portions inexact.  The `printf()'    |
  61. | routines are used to convert the floating-point value into the same    |
  62. | digits that the display shows.                    |
  63. |                                    |
  64. | There must be a better way?                        |
  65. |                                    |
  66. | 90.01.04                                |
  67. \* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  68. #define CVT 48
  69.  
  70. double C_DECL dec_hrs(double h_ms)
  71. {
  72.     char hms_buf[CVT], min_buf[3], *dp;
  73.     double hrs, min, sec;
  74.     int neg;
  75.  
  76.     if (h_ms < 0.0) {
  77.     neg = 1;
  78.     h_ms *= -1.0;
  79.     } else {
  80.     neg = 0;
  81.     }
  82.     sprintf( hms_buf, "%040.20f", ((double)10000.0 * h_ms) );
  83.  
  84.     DBG_FPRINTF((errfile,"\ndec_hrs:  h_ms: %7f  hms_buf: %s\n",h_ms,hms_buf));
  85.  
  86.     for (dp = hms_buf; *dp != '.'; ++dp)
  87.     ;
  88.     dp -= 4;
  89.     min_buf[0] = *dp;
  90.     *dp++ = '\0';
  91.     min_buf[1] = *dp++;
  92.     min_buf[2] = '\0';
  93.  
  94.     sec = atof(dp);
  95.     min = atof(min_buf);
  96.     hrs = atof(hms_buf);
  97.  
  98.     DBG_FPRINTF((errfile,"hms_buf: %s, min_buf: %s, secs(*dp): %s\n"
  99.         "hrs: %f, min: %f, sec: %f\n",
  100.         hms_buf, min_buf, dp, hrs, min, sec
  101.     ));
  102.  
  103.     hrs += min/(double)60.0 + sec/(double)3600.0;
  104.     return ( neg  ?  -hrs  :  hrs );
  105. }
  106.  
  107.  
  108. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
  109. | Format decimal-hour values in "sexagesimal" (hh.mmssttt) style.
  110. | Problems here like in dec_hrs() above.
  111. |
  112. | 89.12.27
  113. */
  114. #define PLACES    9    /* round to nanoseconds */
  115.  
  116. double C_DECL hms(double dec_hr)
  117. {
  118.     unsigned long i_hr;
  119.     unsigned int  i_min, i_sec;
  120.     double        d_min, d_sec;
  121.     char          sec_buf[5 + PLACES], buf[256], *bp;
  122.  
  123.     d_min = 60.0 * frac(dec_hr);
  124.     d_sec = 60.0 * frac( d_min );
  125.  
  126.     sprintf(sec_buf,"%02.*f%c", PLACES, d_sec, '\0');
  127.     for ( bp = sec_buf; *bp != '.'; ++bp )
  128.     {}
  129.     *bp++ = '\0';
  130.  
  131.     i_min = INT_PART( d_min );
  132.     i_sec = (int)strtol(sec_buf, NULL, 0);
  133.     while (i_sec >= 60) {
  134.     i_sec -= 60;
  135.     ++i_min;
  136.     }
  137.     i_hr = (long)INT_PART( dec_hr );
  138.     while (i_min >= 60) {
  139.     i_min -= 60;
  140.     ++i_hr;
  141.     }
  142.  
  143.     sprintf(buf,"%lu.%02u%02u%s%c", i_hr, i_min, i_sec, bp, '\0');
  144.  
  145.     DBG_FPRINTF((errfile,"\nto-hms:  dec_hr: %7f\n"
  146.         "d_min: %f, i_min: %u\nd_sec: %f,  i_sec: %u\n"
  147.         "sec_buf: %s,  bp: %s\nbuf: %s\n"
  148.         "value: %.20f\n",
  149.         dec_hr, d_min, i_min, d_sec, i_sec, sec_buf, bp, buf,
  150.         atof(buf)
  151.     ));
  152.  
  153.     return atof(buf);
  154. }
  155.  
  156. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  157.  
  158. double C_DECL log2(double x) {
  159.     return (log10(x) / log_2);
  160. }
  161.  
  162. double C_DECL p10(double x) {
  163.     return pow((double)10.0, x);
  164. }
  165.  
  166. double C_DECL squar(double x) {
  167.     return (x * x);
  168. }
  169.  
  170. /*
  171. | Gamma & factorial function.  This table copied from CRC Handbook,
  172. | 55th Edition.  Values between 0.0 and 2.0 are looked up in the table;
  173. | larger values are iteratively calculated.  Gamma() overflows at 171.
  174. */
  175. static double gamma_table[101] = {
  176. 1.0, .99433, .98884, .98355, .97844, .97350, .96874, .96415, .95973, .95546,
  177. .95135, .94739, .94359, .93993, .93642, .93304, .92980, .92670, .92373, .92088,
  178. .91817, .91558, .91311, .91075, .90852, .90640, .90440, .90250, .90072, .89904,
  179. .89747, .89600, .89464, .89338, .89222, .89115, .89018, .88931, .88854, .88785,
  180. .88726, .88676, .88636, .88604, .88580, .88565, .88560, .88563, .88575, .88595,
  181. .88623, .88659, .88704, .88757, .88818, .88887, .88964, .89049, .89142, .89243,
  182. .89352, .89468, .89592, .89724, .89864, .90012, .90167, .90330, .90500, .90678,
  183. .90864, .91057, .91258, .91466, .91683, .91906, .92137, .92376, .92623, .92877,
  184. .93138, .93408, .93685, .93969, .94261, .94561, .94869, .95184, .95507, .95838,
  185. .96177, .96523, .96878, .97240, .97610, .97988, .98374, .98768, .99171, .99581, 1.0
  186. };
  187.  
  188. double C_DECL gamma(double x)
  189. {
  190.     double gamma, g1, deltag, x1, deltax;
  191.  
  192.     if (x < DBL_MIN) {
  193.     prterr("gamma", "x < 0");
  194.     return x;
  195.     }
  196.     if ( DBL_MIN <= x && x <= 1.0 ) {
  197.     x1 = (100.0 * x);
  198.     deltax = x1 - INT_PART(x1);
  199.     g1 = gamma_table[ (int)x1 ];
  200.     deltag = (gamma_table[ (int)x1+1 ] - g1);
  201.     return ( (g1 + deltag*deltax) / x );
  202.     }
  203.  
  204.     gamma = (double)1.0;
  205.     while ((double)2.0 < x)
  206.     gamma *= --x;
  207.     x1 = (100.0 * --x);
  208.     deltax = x1 - INT_PART(x1);
  209.     g1 = gamma_table[ (int)x1 ];
  210.     deltag = (gamma_table[ (int)x1+1 ] - g1);
  211.     gamma *= (g1 + deltag*deltax);
  212.     return gamma;
  213. }
  214.  
  215.  
  216. double C_DECL fact(double x) {
  217.     return gamma(++x);
  218. }
  219.  
  220. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  221.  
  222. double C_DECL isinh(double x) {
  223.     return log( x + sqrt( squar(x) + 1 ) );
  224. }
  225.  
  226. double C_DECL icosh(double x) {
  227.     if (x < 1.0) {
  228.     prterr("icosh", "x < 1");
  229.     return x;
  230.     }
  231.     return log( x + sqrt( squar(x) - 1 ) );
  232. }
  233.  
  234. double C_DECL itanh(double x) {
  235.     if (x >= 1.0) {
  236.     prterr("itanh", "x >= 1");
  237.     return x;
  238.     }
  239.     return (0.5 * log( (1.0+x) / (1.0-x) ));
  240. }
  241.  
  242. double C_DECL csch(double x) {
  243.     return ((double)1.0 / sinh(x));
  244. }
  245.  
  246. double C_DECL sech(double x) {
  247.     return ((double)1.0 / cosh(x));
  248. }
  249.  
  250. double C_DECL coth(double x) {
  251.     return ((double)1.0 / tanh(x));
  252. }
  253.  
  254. double C_DECL icsch(double x) {
  255.     return isinh((double)1.0 / x);
  256. }
  257.  
  258. double C_DECL isech(double x) {
  259.     return icosh((double)1.0 / x);
  260. }
  261.  
  262. double C_DECL icoth(double x) {
  263.     return itanh((double)1.0 / x);
  264. }
  265.  
  266.  
  267. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *\
  268. | Conversions.
  269. */
  270.  
  271. double C_DECL fahr(double x) {
  272.     return ( x * (double)1.8 + 32 );
  273. }
  274. double C_DECL celsius(double x) {
  275.     return ( (x - 32) / (double)1.8 );
  276. }
  277.  
  278.  
  279. double C_DECL kg(double x) {
  280.     return ( x * (double)0.45359237 );
  281. }
  282. double C_DECL pounds(double x) {
  283.     return ( x * (double)2.2046226 );
  284. }
  285.  
  286.  
  287. double C_DECL joules(double x) {
  288.     return ( x * (double)4.184 );
  289. }
  290. double C_DECL calories(double x) {
  291.     return ( x * (double)0.239006 );
  292. }
  293.  
  294.  
  295. double C_DECL liters(double x) {
  296.     return ( x * (double)3.7854118 );
  297. }
  298. double C_DECL gallons(double x) {
  299.     return ( x * (double)0.2641794 );
  300. }
  301.  
  302. double C_DECL cuinch(double x) {
  303.     return ( x * (double)231.0 );
  304. }
  305. double C_DECL igal(double x) {
  306.     return ( x / (double)231.0 );
  307. }
  308.  
  309.  
  310. double C_DECL acres(double x) {
  311.     return ( x * (double)2.4710538 );
  312. }
  313. double C_DECL hectares(double x) {
  314.     return ( x / (double)2.4710538 );
  315. }
  316.  
  317.  
  318. double C_DECL mph(double x) {
  319.     return ( x * (double)2.2369363 );
  320. }
  321. double C_DECL mps(double x) {
  322.     return ( x / (double)2.2369363 );
  323. }
  324.  
  325.             /**  Distance conversions  **/
  326.  
  327. double C_DECL meters(double x) {
  328.     return ( x * (double)0.3048 );
  329. }
  330. double C_DECL feet(double x) {
  331.     return ( x / (double)0.3048 );
  332. }
  333.  
  334. double C_DECL km(double x) {
  335.     return ( x * (double)1.609344 );
  336. }
  337. double C_DECL miles(double x) {
  338.     return ( x * (double)0.62137119 );
  339. }
  340.  
  341. double C_DECL yards(double x) {
  342.     return ( x * (double)220 );
  343. }
  344. double C_DECL furlongs(double x) {
  345.     return ( x / (double)220 );
  346. }
  347.  
  348. double C_DECL ly(double x) {
  349.     return ( x / (double)(9.460528347e15) );
  350. }
  351. double C_DECL lymeters(double x) {
  352.     return ( x * (double)(9.460528347e15) );
  353. }
  354.  
  355.  
  356. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - *
  357. | Get fractional part of number.  Share floor() ftn w/ `int' function.
  358. */
  359. double C_DECL frac(double x) {
  360.     return ( x - INT_PART(x) );
  361. }
  362.  
  363.  
  364. /*--------------------------------------------------------------------*\
  365. | Statistical and other directly-called functions.                     |
  366. \*--------------------------------------------------------------------*/
  367.  
  368. void clrreg(int first, int last)
  369. {
  370.     int i;
  371.     for (i = first; i <= last; )
  372.     memory[ i++ ] = 0.0;
  373. }
  374.  
  375. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  376.  
  377. void sumplus(void)
  378. {
  379.     long double x, y;
  380.     shift_lastx();
  381.     memory[10] += ONE;
  382.     memory[11] += (x = (long double)xreg);
  383.     memory[12] += (x * x);
  384.     memory[13] += (y = (long double)yreg);
  385.     memory[14] += (y * y);
  386.     memory[15] += (x * y);
  387.     /*
  388.     | v3.0 - harmonic and geometric means
  389.     */
  390.     memory[16] += (0.0 != x  ?  ONE/x  :  DBL_MAX);
  391.     memory[17] += (0.0 != y  ?  ONE/y  :  DBL_MAX);
  392.     memory[18] *= x;
  393.     memory[19] *= y;
  394.  
  395.     xreg = memory[10];
  396.     stacklift = FALSE;
  397.     clear_state("Sum +");
  398. }
  399.  
  400. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  401.  
  402. void summinus(void)
  403. {
  404.     long double x, y;
  405.     shift_lastx();
  406.     memory[10] -= ONE;
  407.     memory[11] -= (x = (long double)xreg);
  408.     memory[12] -= (x * x);
  409.     memory[13] -= (y = (long double)yreg);
  410.     memory[14] -= (y * y);
  411.     memory[15] -= (x * y);
  412.     /*
  413.     | v3.0 - harmonic and geometric means
  414.     */
  415.     if (0.0 != x) {
  416.     memory[16] -= ONE / x;
  417.     memory[18] /= x;
  418.     } else
  419.     memory[16] -= DBL_MAX;
  420.     if (0.0 != y) {
  421.     memory[17] -= ONE / y;
  422.     memory[19] /= y;
  423.     } else
  424.     memory[17] -= DBL_MAX;
  425.  
  426.     xreg = memory[10];
  427.     stacklift = FALSE;
  428.     clear_state("Sum -");
  429. }
  430.  
  431. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  432.  
  433. static char n0_msg[] = "n is 0";
  434. static char n2_msg[] = "n < 2";
  435.  
  436. void mean(void)
  437. {
  438.     long double n = memory[10];
  439.     if (0.0 == n) {
  440.     prterr("mean", n0_msg);
  441.     } else {
  442.     shift_lastx();
  443.     xreg = memory[11] / n;
  444.     yreg = memory[13] / n;
  445.     }
  446.     clear_state("mean X & Y");
  447. }
  448.  
  449. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  450.  
  451. void geomean(void)
  452. {
  453.     long double in = memory[10];
  454.     if (in == 0.0) {
  455.     prterr("geomean", n0_msg);
  456.     } else {
  457.     in = ONE / in;
  458.     shift_lastx();
  459.     xreg = pow( memory[18], in );
  460.     yreg = pow( memory[19], in );
  461.     }
  462.     clear_state("geo.mean X & Y");
  463. }
  464.  
  465. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  466.  
  467. void harmean(void)
  468. {
  469.     long double n = memory[10];
  470.     if (n == 0.0) {
  471.     prterr("harmean", n0_msg);
  472.     } else {
  473.     shift_lastx();
  474.     xreg = (memory[16] == 0.0  ?  DBL_MAX  :  n / memory[16]);
  475.     yreg = (memory[17] == 0.0  ?  DBL_MAX  :  n / memory[17]);
  476.     }
  477.     clear_state("har.mean X & Y");
  478. }
  479.  
  480. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  481.  
  482. void stddev(void)
  483. {
  484.     long double n, temp, tav;
  485.  
  486.     if ((n = memory[10]) < 2.0) {
  487.     prterr("stddev", n2_msg);
  488.     } else {
  489.     shift_lastx();
  490.     temp = n - ONE;
  491.     tav = memory[11] / n;
  492.     xreg = sqrt( (memory[12] - memory[11] * tav) / temp );
  493.     tav = memory[13] / n;
  494.     yreg = sqrt( (memory[14] - memory[13] * tav) / temp );
  495.     }
  496.     clear_state("std. devs.");
  497. }
  498.  
  499. /*---------------------------------------------------------------------*\
  500. | v3.0 --- linear regression & related functions.            |
  501. |    memory[B0]        bo                    |
  502. |    memory[B1]        b1                    |
  503. |    memory[SB0]        s(b0)                    |
  504. |    memory[TB0]        t(b0)                    |
  505. |    memory[SB1]        s(b1)                    |
  506. |    memory[TB1]        t(b1)                    |
  507. |    memory[SYX]        s( y|x )                |
  508. |    memory[R2]        r-squared                |
  509. |    memory[FR]        F-ratio                    |
  510. |    memory[COV]        covariance                |
  511. | B0, B1, ... COV are defined in ftns.h                    |
  512. \* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  513.  
  514. void linreg(void)
  515. {
  516.     long double n, xbar, ybar, c, det, nu2, t1, r1, m;
  517.  
  518.     n = memory[10];
  519.     if (n < 2.0) {
  520.     prterr("linreg", n2_msg);
  521.     } else {
  522.     xbar = memory[11] / n;
  523.     ybar = memory[13] / n;
  524.     c = n * memory[15] - memory[11] * memory[13];
  525.     det = n * memory[12] - memory[11] * memory[11];
  526.     if (det == 0.0)
  527.         det = DBL_MIN;
  528.     memory[B1] = c / det;                /** b1 coefficient **/
  529.     memory[B0] = ybar - memory[B1] * xbar;        /** b0 coefficient **/
  530.  
  531.     nu2 = n - TWO;
  532.     t1 = n * memory[14] - (memory[13] * memory[13]);
  533.     r1 = c * memory[B1];
  534.     if (t1 == r1)
  535.         m = DBL_MIN;
  536.     else
  537.         m = (t1 - r1) / (n > TWO ? nu2 : n);
  538.     memory[SB1] = m / det;                /** s(b1)-squared **/
  539.     memory[TB1] = memory[B1] / sqrt( memory[SB1] );    /** t(b1) **/
  540.     memory[SB0] = memory[SB1] * memory[12] / n;    /** s(b0)-squared **/
  541.     memory[TB0] = memory[B0] / sqrt( memory[SB0] );    /** t(b0) **/
  542.     memory[SYX] = m / n;                /** s(y|x)-squared **/
  543.     if (t1 == 0.0)
  544.         memory[R2] = DBL_MAX;            /** r-squared **/
  545.     else
  546.         memory[R2] = r1 / t1;            /** r-squared **/
  547.     memory[FR] = r1 / m;                /** F-ratio **/
  548.     memory[COV] = c / (n * (nu2 + ONE));        /** covariance **/
  549.  
  550.     treg = memory[R2];
  551.     zreg = sqrt( memory[SYX] );
  552.     yreg = memory[B0];
  553.     xreg = memory[B1];
  554.     lastx = memory[COV];
  555.     }
  556.     clear_state("linear regr");
  557. }
  558.  
  559. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  560.  
  561. void linstats(void)
  562. {
  563.     treg = memory[TB0];
  564.     zreg = sqrt( memory[SB0] );
  565.     yreg = memory[TB1];
  566.     xreg = sqrt( memory[SB1] );
  567.     lastx = memory[FR];
  568.     clear_state("linreg stats");
  569. }
  570.  
  571. /*-------------------------------------------------------*\
  572. | Generate & store linear-interpolation constants for use |
  573. | by interpx() and interpy().  Use B0 and B1 registers,      |
  574. | compatibly with the linear regression function.      |
  575. \* - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  576.  
  577. void lin_coeffs(void)
  578. {
  579.     if (yreg == treg) {
  580.     prterr("lincoeffs", "x1 = x2");
  581.     } else {
  582.     /*
  583.     | b1 = delta-y / delta-x
  584.     */
  585.     memory[B1] = ((long double)xreg - (long double)zreg)
  586.             / ((long double)yreg - (long double)treg);
  587.     /*
  588.     | b0 = y-low  -  x-low * b1
  589.     */
  590.     memory[B0] = (long double)zreg - (long double)treg * memory[B1];
  591.     }
  592.     clear_state("linear coeffs");
  593. }
  594.  
  595. /*-------------------------------------------------------*/
  596.  
  597. double C_DECL interpx(double y)
  598. {
  599.     if (memory[B1] == 0.0) {
  600.     prterr("interpx","B1 is 0");
  601.     return xreg;
  602.     }
  603.     return (y - memory[B0]) / memory[B1];
  604. }
  605.  
  606. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  607.  
  608. double C_DECL interpy(double x)
  609. {
  610.      return memory[B0] + (memory[B1] * x);
  611. }
  612.  
  613. /**\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\**/
  614.  
  615. const char last_line[] = "\r\n  --------\r\n";
  616.  
  617. static char stat_fmt[] = 
  618.     "\r\n\r\nLINEAR REGRESSION RESULTS  ( y = b0  +  b1 * x )\r\n"
  619.     "  b0: %.6le   s(b0): %.6le   t(b0): %.6le\r\n"
  620.     "  b1: %.6le   s(b1): %.6le   t(b1): %.6le\r\n"
  621.     "  n: %.0lf    s( y|x ): %.6le    r-squared: %.6lf\r\n"
  622.     "  F-ratio (nu1=2, nu2=%u): %.6le    covariance: %.6le"
  623.     "%sprtlin\r\n\r\n" ;
  624.  
  625. void prtlin(void)
  626. {
  627.     if (savefile) {
  628.     fprintf(savefile,stat_fmt,
  629.         (double)memory[B0], sqrt( memory[SB0] ), (double)memory[TB0],
  630.         (double)memory[B1], sqrt( memory[SB1] ), (double)memory[TB1],
  631.         (double)memory[10], sqrt( memory[SYX] ), (double)memory[R2],
  632.         ((unsigned)memory[10] - 2), (double)memory[FR],
  633.         (double)memory[COV], last_line);
  634.     }
  635.     clear_state("prtlin");
  636.     write_save = FALSE;
  637. }
  638.  
  639. /*--------------------------------------------------------------------*/
  640.  
  641. static char sum_fmt1[] =
  642.     "\r\nSUMMATION REGISTERS:\r\n"
  643.     "n: %Lg\t  sum(x): %8Lg   sum(x*x): %8Lg\r\n"
  644.     "\t  sum(y): %8Lg   sum(y*y): %8Lg   sum(x*y): %8Lg\r\n"
  645.     "\t  sum-of-inverses(x): %8Lg   sum-of-inverses(y): %8Lg\r\n"
  646.     "\t  product(x): %8Lg   product(y): %8Lg\r\n";
  647. static char sum_fmt2[] =
  648.     "MEAN, SAMPLE STD. DEV.; Geometric Mean, Harmonic Mean\r\n"
  649.     "y-bar: %8Lg    s(y): %8lg\r\n\tgeo.mean: %8lg    harm.mean: %8lg\r\n"
  650.     "x-bar: %8Lg    s(x): %8lg\r\n\tgeo.mean: %8lg    harm.mean: %8lg"
  651.     "%sprtsum\r\n\r\n" ;
  652.  
  653.  
  654. void prtsum(void)
  655. {
  656.     long double n, n1, in, xbar, ybar;
  657.     double stdx, stdy, geox,geoy, harx, hary;
  658.  
  659.     if (savefile) {
  660.     fprintf(savefile, sum_fmt1,
  661.         memory[10], memory[11],memory[12], memory[13],memory[14],
  662.         memory[15], memory[16],memory[17], memory[18],memory[19],
  663.         last_line);
  664.  
  665.     if ((n = memory[10]) < 2) {
  666.         fprintf(savefile,
  667.         "N TOO SMALL FOR STATISTICS.\r\nprtsum\r\n\r\n");
  668.     } else {
  669.         in = ONE / n;
  670.         n1 = n - 1.0;
  671.         xbar = memory[11] / n;
  672.         ybar = memory[13] / n;
  673.         stdx = sqrt( (memory[12] - xbar*memory[11]) / n1 );
  674.         stdy = sqrt( (memory[14] - ybar*memory[13]) / n1 );
  675.         harx = (memory[16] == 0.0  ?  DBL_MAX  :  n / memory[16]);
  676.         hary = (memory[17] == 0.0  ?  DBL_MAX  :  n / memory[17]);
  677.         geox = pow( memory[18], in );
  678.         geoy = pow( memory[19], in );
  679.  
  680.         fprintf(savefile, sum_fmt2,
  681.         ybar, stdy, geoy, hary,  xbar, stdx, geox, harx );
  682.     }
  683.     }
  684.     clear_state("prtsum");
  685.     write_save = FALSE;
  686. }
  687.  
  688. /*--------------------------------------------------------------------*/
  689.  
  690. static char stk_dump[] =
  691.     "\r\nSTACK:\r\n"
  692.         "  t: %.20lg   z: %.20lg\r\n"
  693.         "  y: %.20lg   x: %.20lg\r\n\t\t\t\tLastX: %.20lg"
  694.         "%sprtstk\r\n\r\n";
  695.  
  696. void prtstk(void)
  697. {
  698.     if (savefile)
  699.     fprintf(savefile, stk_dump, treg, zreg, yreg, xreg, lastx, last_line);
  700.     clear_state("prtstk");
  701.     write_save = FALSE;
  702. }
  703.  
  704. /*--------------------------------------------------------------------*/
  705.  
  706. void prtreg(void)
  707. {
  708.     int i;
  709.     if (savefile) {
  710.     fprintf(savefile,"\r\nNon-Zero MEMORY REGISTERS:");
  711.     for (i = 0; i < MEMSIZE; ++i)
  712.         if ((long double)0.0 != memory[i])
  713.         fprintf(savefile,"\r\n  memory[ %d ]: %.20Lg", i, memory[i]);
  714.     fprintf(savefile,"%sprtreg\r\n\r\n", last_line);
  715.     }
  716.     clear_state("prtreg");
  717.     write_save = FALSE;
  718. }
  719.  
  720. /**\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\**/
  721.  
  722. void ru(void)
  723. {
  724.     double temp;
  725.  
  726.     temp = treg;
  727.     treg = zreg;
  728.     zreg = yreg;
  729.     yreg = xreg;
  730.     xreg = temp;
  731.     clear_state("rollup");
  732. }
  733.  
  734. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  735.  
  736. void rd(void)
  737. {
  738.     double temp;
  739.  
  740.     temp = xreg;
  741.     xreg = yreg;
  742.     yreg = zreg;
  743.     zreg = treg;
  744.     treg = temp;
  745.     clear_state("rolldown");
  746. }
  747.  
  748. /**\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\**/
  749.  
  750. void polar(void)
  751. {
  752.     double ty;
  753.  
  754.     shift_lastx();
  755.     ty = atan2( yreg, xreg );        /** theta **/
  756.     if (trig_mode == DEGREES)
  757.     ty *= RAD_TO_DEG;
  758.     if (!math_error) {
  759.     xreg = hypot(yreg, xreg);        /** R **/
  760.     yreg = ty;
  761.     }
  762.     clear_state("X,Y \x1A polar");
  763. }
  764.  
  765. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  766.  
  767. void rect(void)
  768. {
  769.     double temp, tx, ty;
  770.  
  771.     shift_lastx();
  772.     tx = xreg; ty = yreg;
  773.     if (trig_mode == DEGREES)
  774.     yreg *= DEG_TO_RAD;
  775.     temp = xreg * cos(yreg);                /** X **/
  776.     yreg = xreg * sin(yreg);                /** Y **/
  777.     xreg = temp;
  778.     if (math_error) {
  779.     xreg = tx; yreg = ty;
  780.     }
  781.     clear_state("R,\xE9 \x1A rect");
  782. }
  783.  
  784. /**\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\**/
  785.  
  786. void atan_2(void)
  787. {
  788.     double temp;
  789.     temp = atan2(yreg, xreg);
  790.     if (!math_error) {
  791.     if (trig_mode == DEGREES)
  792.         temp *= RAD_TO_DEG;
  793.     pop();
  794.     xreg = temp;
  795.     }
  796.     clear_state("arctan( Y/X )");
  797. }
  798.  
  799. /*---------------------------------------------------------------------*/
  800.  
  801. void power(void)
  802. {
  803.     pop();
  804.     xreg = pow(xreg, lastx);
  805.     clear_state("y^x");
  806. }
  807.  
  808. /*---------------------------------------------------------------------*/
  809.  
  810. /*
  811. | The following two functions are the original (HP29-faithful) conversions.
  812. | Unlike all the other unary functions, these check for arith. errors.
  813. | (sure would be nice if I could trap these.)  Since they're unusual,
  814. | they are treated as nullary functions.
  815. */
  816.  
  817. void rad_deg(void)
  818. {
  819.     if (mul_ok(xreg, RAD_TO_DEG, "R->D")) {
  820.     xreg *= RAD_TO_DEG;
  821.     clear_state("rads \x1A Degs");
  822.     } else
  823.     clear_state(lastfunct);
  824. }
  825.  
  826. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  827.  
  828. void deg_rad(void)
  829. {
  830.     if (mul_ok(xreg, DEG_TO_RAD, "D->R")) {
  831.     xreg *= DEG_TO_RAD;
  832.     clear_state("degs \x1A Rads");
  833.     } else
  834.     clear_state(lastfunct);
  835. }
  836.  
  837. /**\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\**/
  838.  
  839.  
  840. /*------------------------------*\
  841. | Nullary-function lookup table. |
  842. \*------------------------------*/
  843.  
  844. struct ventry {
  845.     char *name;
  846.     vf_ptr func_ptr;
  847. };
  848.  
  849. static struct ventry nullary_fn[] = {            /* NULL-ARY */
  850.     "sumplus",sumplus, "summinus",summinus, "mean",mean,
  851.     "geomean",geomean, "harmean",harmean, "stddev",stddev, "sd",stddev,
  852.     "linreg",linreg, "linstats",linstats, "lincoeffs",lin_coeffs,
  853.     "prtlin",prtlin, "prtsum",prtsum, "prtstk",prtstk, "prtreg",prtreg,
  854.  
  855.     "ru",ru, "rollup",ru, "rd",rd, "rolldown",rd,
  856.     "polar",polar, "rect",rect, "atan2",atan_2, "pow",power,
  857.     "deg",rad_deg, "rad",deg_rad,
  858.  
  859.     "", (vf_ptr)NULL
  860. };
  861.  
  862.  
  863. /*-----------------------------------------------*\
  864. | The generalized null-function-finder function. |
  865. \* - - - - - - - - - - - - - - - - - - - - - - - */
  866.  
  867. vf_ptr funct_0(char *name)
  868. {
  869.     struct ventry *ptr;
  870.  
  871.     DBG_FPRINTF((errfile,
  872.         "\tfunct_0: nullary_fn: %d\n",
  873.         sizeof(nullary_fn)/sizeof(struct ventry)));
  874.  
  875.     for (ptr = nullary_fn; ptr->func_ptr != (vf_ptr)NULL; ptr++) {
  876.         if (strcmp(name, ptr->name) == 0)
  877.             return ptr->func_ptr;
  878.     }
  879.     return (vf_ptr)NULL;
  880. }
  881.  
  882. /**\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\**/
  883.  
  884.  
  885. /*---------------------------------------------------------------------*\
  886. | The generalized unary-function-finder function and its lookup table.    |
  887. | Kept at the end of this file so that the table can be initialized.    |
  888. \*---------------------------------------------------------------------*/
  889.  
  890. struct entry {
  891.     char *name;
  892.     f_ptr func_ptr;
  893. };
  894.  
  895. /*
  896. | Look-Up Tables for Multi-char functions  ---  the defined constants
  897. | UNARY, TRIG, I_TRIG are used by do_funct() to select the correct table,
  898. | although do_funct() doesn't know anything about the tables themselves.
  899. */
  900. static struct entry unary_fn[] = {                /* UNARY */
  901.     "sinh", sinh, "cosh", cosh, "tanh", tanh, "abs", fabs,
  902.     "sqrt", sqrt, "int", floor, "ln", log, "log", log10,
  903. /* local... */
  904.     "hms", hms, "hrs", dec_hrs, "lg", log2, "exp", exp,
  905.     "p10", p10,   "pow10", p10,   "frac", frac,   "sqr", squar,
  906.  
  907. /* v3.0 */
  908.     "gamma",gamma, "fact",fact,
  909.  
  910.     "isinh",isinh, "icosh",icosh, "itanh",itanh, "csch",csch, "sech",sech,
  911.     "coth",coth, "icsch",icsch, "isech",isech, "icoth",icoth,
  912.  
  913. /** conversions **/
  914.     "fahr",fahr, "celsius",celsius, "kg",kg, "lb",pounds,
  915.     "joules",joules, "cal",calories, "liters",liters, "gal",gallons,
  916.     "igal",igal, "cuinch",cuinch, "acres",acres, "hectares",hectares,
  917.     "mph",mph, "mps",mps, "meters",meters, "feet",feet,
  918.     "miles",miles, "km",km, "yards",yards, "furlongs",furlongs,
  919.     "ly",ly, "lymeters",lymeters,
  920.  
  921. /** interpolation --- dovetails with linear regression **/
  922.     "interpx",interpx, "interpy",interpy,
  923.  
  924.     "", (f_ptr)NULL
  925. };
  926.  
  927. /*
  928. | TRIG --- has to deal with degree/radian conversions
  929. */
  930. static struct entry trig_fn[] = {
  931.     "sin", sin, "cos", cos, "tan", tan, "", (f_ptr)NULL
  932. };
  933.  
  934. /*
  935. | I_TRIG --- (inverse trig) has to deal with degree/radian conversions
  936. */
  937. static struct entry i_trig_fn[] = {
  938.     "asin", asin, "acos", acos, "atan", atan,
  939.     "arcsin", asin, "arccos", acos, "arctan", atan, "", (f_ptr)NULL
  940. };
  941.  
  942.  
  943. /*-----------------------------------------------*\
  944. | The generalized unary-function-finder function. |
  945. \* - - - - - - - - - - - - - - - - - - - - - - - */
  946.  
  947. f_ptr funct_1(char *name, int type)
  948. {
  949.     struct entry *ptr;
  950.  
  951.     DBG_FPRINTF((errfile,
  952.         "\tfunct_1: unary_fn: %d; trig_fn: %d; i_trig_fn: %d\n",
  953.         sizeof(unary_fn)/sizeof(struct entry),
  954.         sizeof(trig_fn)/sizeof(struct entry),
  955.         sizeof(i_trig_fn)/sizeof(struct entry)));
  956.  
  957.     switch (type) {
  958.     case UNARY:
  959.     ptr = unary_fn;
  960.     break;
  961.     case TRIG:
  962.     ptr = trig_fn;
  963.     break;
  964.     case I_TRIG:
  965.     ptr = i_trig_fn;
  966.     break;
  967.     }
  968.     for ( ; ptr->func_ptr != (f_ptr)NULL; ptr++) {
  969.         if (strcmp(name, ptr->name) == 0)
  970.             return ptr->func_ptr;
  971.     }
  972.     return (f_ptr)NULL;
  973. }
  974.  
  975. /**\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\**/
  976.