1 #include <config.h>
2 #include <curses.h>
3 #include <math.h>
4 #include "sc.h"
5
6 #ifdef HAVE_X11_X_H
7 #include <X11/Xlib.h>
8 #include <X11/Xutil.h>
9 #include "scXstuff.h"
10 #endif /* HAVE_X11_X_H */
11
12 static double cash_flow PROTO((double, double *, int, int, int, int));
13 static double dorlirr PROTO((int, int, int, int));
14 static void populate_power PROTO((double, double *, int));
15 static void set_step PROTO((int, int, int, int, int *, int *));
16 static int valid_nrange PROTO((int, int, int, int, int));
17
18 extern int cellerror; /* interp.c: is there an error in this cell */
19
20 #ifndef HAVE_RINT
21 /** round-to-even, also known as ``banker's rounding''.
22 With round-to-even, a number exactly halfway between two values is
23 rounded to whichever is even; e.g. rnd(0.5)=0, rnd(1.5)=2,
24 rnd(2.5)=2, rnd(3.5)=4. This is the default rounding mode for
25 IEEE floating point, for good reason: it has better numeric
26 properties. For example, if X+Y is an integer,
27 then X+Y = rnd(X)+rnd(Y) with round-to-even,
28 but not always with sc's rounding (which is
29 round-to-positive-infinity). I ran into this problem when trying to
30 split interest in an account to two people fairly.
31 **/
32 double
rint(d)33 rint(d)
34 double d;
35 {
36 /* as sent */
37 double fl = floor(d), fr = d - fl;
38
39 return ((fr < 0.5) || ((fr == 0.5) && (fl == floor(fl/2) * 2)))
40 ? fl : ceil(d);
41 }
42 #endif
43
44
45 /*
46 * pow10 calculates the power function of base 10
47 */
48 #ifndef HAVE_POW10
49 double
pow10(p)50 pow10(p)
51 double p;
52 {
53 double q;
54
55 p = floor(p);
56 if (p >= 0) {
57 for (q = 1; p > 0; --p)
58 q = q * 10;
59 }
60 else {
61 p = -p;
62 for (q = 1; p > 0; --p)
63 q = q / 10;
64 }
65 return q;
66 }
67 #endif /* linux */
68
69 /***
70 function scerror() used to be a macro, but the X call is more complicated than
71 the curses version was
72 ***/
73 void
scerror(errstring)74 scerror(errstring)
75 char *errstring;
76 {
77
78 #ifdef PSC
79 fprintf(stderr, errstring);
80 #else
81 # ifdef HAVE_X11_X_H
82 if (using_X)
83 {
84 clearlines(1, 1);
85 XBell(dpy, 100);
86 /*fprintf(stderr,"\007");*/
87 XDrawImageString(dpy, mainwin, maingc,
88 textcol(0), textrow(1),
89 errstring, strlen(errstring));
90 XFlush(dpy);
91 seenerr = 1;
92 } else
93 # endif /* HAVE_X11_X_H */
94 { move(1,0); clrtoeol(); printw("%s", errstring);
95 } /* HAVE_X11_X_H, end curses */
96 #endif
97 }
98
99
100 /* =============================================== */
101 /* This function displays the input data or message*/
102 /* at the first line of the spread sheet screen */
103 /* for approximately one second. */
104 /* =============================================== */
105
106 void
message(x)107 message(x)
108 char *x; /* string for display */
109 {
110 #ifdef PSC
111 fprintf(stderr, x);
112 #else
113 # ifdef HAVE_X11_X_H
114 if (using_X)
115 {
116 clearlines(0,0);
117 XDrawImageString(dpy, mainwin, maingc,
118 textcol(0), textrow(0),
119 x, strlen(x));
120 XFlush(dpy); /* force it onto the screen */
121 sleep(1); /* delay 1 second */
122 clearlines(0,0);
123 } else
124 # endif /* HAVE_X11_X_H */
125 { move(1,0); clrtoeol(); printw("%s", x);
126 } /* HAVE_X11_X_H, end curses */
127 #endif
128 } /* end of message */
129
130
131 #ifndef PSC
132 /*
133 * DOIRR -- calculates the "internal-rate-of-return" for a cash flow
134 * over equal length intervals, designated in the range. I.e.
135 * the rate-of-return which would yield a cash flow with these properties,
136 * common in bond-returns. E.g. -103.4 9.13 9.13 109.13 might be
137 * the cell contents for a bond which costs 103.4, returns 9 1/8% on
138 * par value 100, and then returns the principal and last payment
139 * all at once.
140 *
141 * Formula:
142 * based on solving for "r" in:
143 * t
144 * Sum CF(j) / (1+r)^j
145 * j = 0
146 */
147 double
doirr(minr,minc,maxr,maxc)148 doirr(minr, minc, maxr, maxc)
149 int minr, minc, maxr, maxc;
150 {
151 static double ret = 0;
152 /* int cinc = 0, rinc = 0;*/
153 double dorlirr();
154
155 /* first check validity of all entries,
156 * as well as validity of the range
157 */
158 if (minr != maxr && minc != maxc) {
159 /* range is wrong shape, the formula needs changing */
160 scerror(" range specified to @doirr");
161 cellerror = CELLERROR;
162 return ret;
163 }
164 /* must be at least 2 numbers in the cash flow. */
165 if (!valid_nrange(minr, minc, maxr, maxc, 2))
166 {
167 /* formula may be fine, range values may be changed */
168 cellerror = CELLINVALID;
169 return ret;
170 }
171
172 /* now run the irr approximation */
173 return dorlirr(minr, minc, maxr, maxc);
174 }
175
176
177 /* calculate @irr() over range, approximating the rate, using exponential
178 * doubling to find an upper bound for a guess, then narrowing in using
179 * binary search.
180 */
181 static double
dorlirr(minr,minc,maxr,maxc)182 dorlirr(minr, minc, maxr, maxc)
183 int minr, minc, maxr, maxc;
184 {
185 double guess = 1.0;
186 double err = 0.0001;
187 double rate = guess;
188 double *rate_pow;
189 int growing = 1; /* finding upper bound for rate */
190 int npow;
191 double fabs();
192 double oval = -123456.0; /* arbitrary number */
193 double val, cash_flow();
194
195 /* rate power table */
196 npow = (maxr-minr+1) *(maxc-minc+1) + 1;
197 rate_pow = (double *)scxmalloc(sizeof(double)*npow);
198 /* repeatedly guess */
199 for (;;)
200 {
201 populate_power(rate, rate_pow, npow);
202 val = cash_flow(rate, rate_pow, minr, minc, maxr, maxc);
203 if (fabs(val) <= err)
204 break;
205 if (fabs(val - oval) <= err || fabs(rate) <= err) {
206 /* not converging, no rate */
207 cellerror = CELLERROR;
208 break;
209 }
210 oval = val;
211 /* adjust guess */
212 if (val > 0.0 && growing) {
213 /* still trying to find an upper bound */
214 rate += guess;
215 guess *= 2;
216 }
217 else {
218 /* bin search */
219 guess *= 0.5;
220 if (val > 0.0) {
221 /* grow rate */
222 rate += guess;
223 }
224 else {
225 /* diminish rate */
226 growing = 0;
227 rate -= guess;
228 }
229 }
230 }
231
232 scxfree((char *)rate_pow);
233 return rate;
234 }
235
236 /*
237 * valid numeric range?
238 * emptyok: -1 -- all range must be numeric
239 * # -- skip non-numeric or missing, must be at least #
240 * numerics present
241 * any cellerror values will cause invalid range.
242 */
243 static int
valid_nrange(minr,minc,maxr,maxc,emptyok)244 valid_nrange(minr, minc, maxr, maxc, emptyok)
245 int minr, minc, maxr, maxc;
246 int emptyok; /* accept empty or non-n cells */
247 {
248 register struct ent *p;
249 int cinc, rinc;
250 int numerics = 0;
251
252 set_step(minr, minc, maxr, maxc, &rinc, &cinc);
253 for (; minr <= maxr && minc <= maxc; minr += rinc, minc += cinc) {
254 p = *ATBL(tbl, minr, minc);
255 if (p) {
256 /* error */
257 if (p->cellerror)
258 return 0;
259 /* valid number? */
260 if (p->flags & is_valid)
261 numerics++;
262 /* !ok to be empty */
263 else if (emptyok == -1)
264 return 0;
265 }
266 else if (emptyok == -1)
267 return 0;
268 }
269 return numerics >= emptyok;
270 }
271
272 /* for one-dim matrices, sets steps to traverse. */
273 static void
set_step(minr,minc,maxr,maxc,rincp,cincp)274 set_step(minr, minc, maxr, maxc, rincp, cincp)
275 int minr, minc, maxr, maxc;
276 int *cincp, *rincp;
277 {
278 *cincp = *rincp = 0;
279 /* establish steps */
280 if (minr == maxr)
281 *cincp = 1;
282 else
283 *rincp = 1;
284 }
285
286
287 static void
populate_power(rate,rate_pow,npow)288 populate_power(rate, rate_pow, npow)
289 double rate, *rate_pow;
290 int npow;
291 {
292 double c = 1.0;
293 while (--npow >= 0) {
294 *rate_pow++ = c;
295 c *= rate;
296 }
297 }
298
299
300 static double
cash_flow(rate,rate_pow,minr,minc,maxr,maxc)301 cash_flow(rate, rate_pow, minr, minc, maxr, maxc)
302 double rate;
303 double *rate_pow;
304 int minr, minc, maxr, maxc;
305 {
306 int rinc, cinc;
307 struct ent *p;
308 double ret;
309
310 ret = 0.0;
311 set_step(minr, minc, maxr, maxc, &rinc, &cinc);
312 for (; minr <= maxr && minc <= maxc; minr += rinc, minc += cinc)
313 /* skip empties and labels. */
314 if ((p = *ATBL(tbl, minr, minc)) && (p->flags&is_valid))
315 ret += (*ATBL(tbl, minr, minc))->v / *rate_pow++;
316 return (ret);
317 }
318 #endif /* PSC */
319