![[BACK]](/icons/cvsweb/back.gif){kind=icon}
Return to itvnum.c CVS log ![[TXT]](/icons/cvsweb/text.gif){kind=icon}
![[DIR]](/icons/cvsweb/dir.gif){kind=icon}
Up to [local] / OpenXM_contrib2 / asir2000 / builtin|
Return to itvnum.c CVS log | Up to [local] / OpenXM_contrib2 / asir2000 / builtin |
1.1 saito 1: /*
1.5 ! kondoh 2: * $OpenXM: OpenXM_contrib2/asir2000/builtin/itvnum.c,v 1.4 2005/02/08 16:53:00 saito Exp $
1.1 saito 3: */
4:
5: #include "ca.h"
6: #include "parse.h"
7: #include "version.h"
8:
9: #if defined(INTERVAL)
10:
11: static void Pitv(NODE, Obj *);
12: static void Pitvd(NODE, Obj *);
13: static void Pitvbf(NODE, Obj *);
14: static void Pinf(NODE, Obj *);
15: static void Psup(NODE, Obj *);
16: static void Pmid(NODE, Obj *);
17: static void Pabsitv(NODE, Obj *);
18: static void Pdisjitv(NODE, Obj *);
19: static void Pinitv(NODE, Obj *);
20: static void Pcup(NODE, Obj *);
21: static void Pcap(NODE, Obj *);
22: static void Pwidth(NODE, Obj *);
23: static void Pdistance(NODE, Obj *);
1.3 saito 24: static void Pitvversion(Q *);
1.1 saito 25: #endif
26: static void Pprintmode(NODE, Obj *);
27:
28: #if defined(__osf__) && 0
29: int end;
30: #endif
31:
32: struct ftab interval_tab[] = {
33: {"printmode",Pprintmode,1},
34: #if defined(INTERVAL)
35: {"itvd",Pitvd,-2},
36: {"intvald",Pitvd,-2},
37: {"itv",Pitv,-2},
38: {"intval",Pitv,-2},
39: {"itvbf",Pitvbf,-2},
40: {"intvalbf",Pitvbf,-2},
41: {"inf",Pinf,1},
42: {"sup",Psup,1},
43: {"absintval",Pabsitv,1},
44: {"disintval",Pdisjitv,2},
45: {"inintval",Pinitv,2},
46: {"cup",Pcup,2},
47: {"cap",Pcap,2},
48: {"mid",Pmid,1},
49: {"width",Pwidth,1},
50: {"diam",Pwidth,1},
51: {"distance",Pdistance,2},
52: {"iversion",Pitvversion,0},
53: #endif
54: {0,0,0},
55: };
56:
57: #if defined(INTERVAL)
58: static void
1.4 saito 59: Pitvversion(Q *rp)
1.1 saito 60: {
1.3 saito 61: STOQ(ASIR_VERSION, *rp);
1.1 saito 62: }
63:
64: extern int bigfloat;
65:
66: static void
67: Pitv(NODE arg, Obj *rp)
68: {
69: Num a, i, s;
70: Itv c;
71: double inf, sup;
72:
73: #if 1
74: if ( bigfloat )
75: Pitvbf(arg, rp);
76: else
77: Pitvd(arg,rp);
78: #else
79: asir_assert(ARG0(arg),O_N,"itv");
80: if ( argc(arg) > 1 ) {
81: asir_assert(ARG1(arg),O_N,"itv");
82: istoitv((Num)ARG0(arg),(Num)ARG1(arg),&c);
83: } else {
84: a = (Num)ARG0(arg);
85: if ( ! a ) {
86: *rp = 0;
87: return;
88: }
1.2 kondoh 89: else if ( NID(a) == N_IP || NID(a) == N_IntervalBigFloat) {
1.1 saito 90: *rp = (Obj)a;
91: return;
92: }
1.2 kondoh 93: else if ( NID(a) == N_IntervalDouble ) {
94: inf = INF((IntervalDouble)a);
95: sup = SUP((IntervalDouble)a);
1.1 saito 96: double2bf(inf, (BF *)&i);
97: double2bf(sup, (BF *)&s);
98: istoitv(i,s,&c);
99: }
100: else istoitv(a,a,&c);
101: }
1.2 kondoh 102: if ( NID( c ) == N_IntervalBigFloat )
103: addulp((IntervalBigFloat)c, (IntervalBigFloat *)rp);
1.1 saito 104: else *rp = (Obj)c;
105: #endif
106: }
107:
108: static void
109: Pitvbf(NODE arg, Obj *rp)
110: {
111: Num a, i, s;
112: Itv c;
113: BF ii,ss;
114: double inf, sup;
115:
116: asir_assert(ARG0(arg),O_N,"intvalbf");
117: a = (Num)ARG0(arg);
118: if ( argc(arg) > 1 ) {
119: asir_assert(ARG1(arg),O_N,"intvalbf");
120: i = (Num)ARG0(arg);
121: s = (Num)ARG1(arg);
122: ToBf(i, &ii);
123: ToBf(s, &ss);
124: istoitv((Num)ii,(Num)ss,&c);
125: } else {
126: if ( ! a ) {
127: *rp = 0;
128: return;
129: }
130: else if ( NID(a) == N_IP ) {
131: itvtois((Itv)a, &i, &s);
132: ToBf(i, &ii);
133: ToBf(s, &ss);
134: istoitv((Num)ii,(Num)ss,&c);
135: }
1.2 kondoh 136: else if ( NID(a) == N_IntervalBigFloat) {
1.1 saito 137: *rp = (Obj)a;
138: return;
139: }
1.2 kondoh 140: else if ( NID(a) == N_IntervalDouble ) {
141: inf = INF((IntervalDouble)a);
142: sup = SUP((IntervalDouble)a);
1.1 saito 143: double2bf(inf, (BF *)&i);
144: double2bf(sup, (BF *)&s);
145: istoitv(i,s,&c);
146: }
147: else {
148: ToBf(a, (BF *)&i);
149: istoitv(i,i,&c);
150: }
151: }
1.2 kondoh 152: if ( c && OID( c ) == O_N && NID( c ) == N_IntervalBigFloat )
153: addulp((IntervalBigFloat)c, (IntervalBigFloat *)rp);
1.1 saito 154: else *rp = (Obj)c;
155: }
156:
157: static void
158: Pitvd(NODE arg, Obj *rp)
159: {
160: double inf, sup;
161: Num a, a0, a1, t;
162: Itv ia;
1.2 kondoh 163: IntervalDouble d;
1.1 saito 164:
165: asir_assert(ARG0(arg),O_N,"intvald");
166: a0 = (Num)ARG0(arg);
167: if ( argc(arg) > 1 ) {
168: asir_assert(ARG1(arg),O_N,"intvald");
169: a1 = (Num)ARG1(arg);
170: } else {
1.2 kondoh 171: if ( a0 && OID(a0)==O_N && NID(a0)==N_IntervalDouble ) {
172: inf = INF((IntervalDouble)a0);
173: sup = SUP((IntervalDouble)a0);
174: MKIntervalDouble(inf,sup,d);
1.1 saito 175: *rp = (Obj)d;
176: return;
177: }
178: a1 = (Num)ARG0(arg);
179: }
180: if ( compnum(0,a0,a1) > 0 ) {
181: t = a0; a0 = a1; a1 = t;
182: }
183: inf = ToRealDown(a0);
184: sup = ToRealUp(a1);
1.2 kondoh 185: MKIntervalDouble(inf,sup,d);
1.1 saito 186: *rp = (Obj)d;
187: }
188:
189: static void
190: Pinf(NODE arg, Obj *rp)
191: {
192: Num a, i, s;
193: Real r;
194: double d;
195:
196: a = (Num)ARG0(arg);
197: if ( ! a ) {
198: *rp = 0;
199: } else if ( OID(a) == O_N ) {
200: switch ( NID(a) ) {
1.2 kondoh 201: case N_IntervalDouble:
202: d = INF((IntervalDouble)a);
1.1 saito 203: MKReal(d, r);
204: *rp = (Obj)r;
205: break;
206: case N_IP:
1.2 kondoh 207: case N_IntervalBigFloat:
208: case N_IntervalQuad:
1.1 saito 209: itvtois((Itv)ARG0(arg),&i,&s);
210: *rp = (Obj)i;
211: break;
1.5 ! kondoh 212: default:
1.1 saito 213: *rp = (Obj)a;
214: break;
215: }
216: } else {
217: *rp = (Obj)a;
218: }
219: }
220:
221: static void
222: Psup(NODE arg, Obj *rp)
223: {
224: Num a, i, s;
225: Real r;
226: double d;
227:
228: a = (Num)ARG0(arg);
229: if ( ! a ) {
230: *rp = 0;
231: } else if ( OID(a) == O_N ) {
232: switch ( NID(a) ) {
1.2 kondoh 233: case N_IntervalDouble:
234: d = SUP((IntervalDouble)a);
1.1 saito 235: MKReal(d, r);
236: *rp = (Obj)r;
237: break;
238: case N_IP:
1.2 kondoh 239: case N_IntervalBigFloat:
240: case N_IntervalQuad:
1.1 saito 241: itvtois((Itv)ARG0(arg),&i,&s);
242: *rp = (Obj)s;
243: break;
1.5 ! kondoh 244: default:
1.1 saito 245: *rp = (Obj)a;
246: break;
247: }
248: } else {
249: *rp = (Obj)a;
250: }
251: }
252:
253: static void
254: Pmid(NODE arg, Obj *rp)
255: {
256: Num a, s;
257: Real r;
258: double d;
259:
260: a = (Num)ARG0(arg);
261: if ( ! a ) {
262: *rp = 0;
263: } else switch (OID(a)) {
264: case O_N:
1.2 kondoh 265: if ( NID(a) == N_IntervalDouble ) {
266: d = ( INF((IntervalDouble)a)+SUP((IntervalDouble)a) ) / 2.0;
1.1 saito 267: MKReal(d, r);
268: *rp = (Obj)r;
1.2 kondoh 269: } else if ( NID(a) == N_IntervalQuad ) {
1.1 saito 270: error("mid: not supported operation");
271: *rp = 0;
1.2 kondoh 272: } else if ( NID(a) == N_IP || NID(a) == N_IntervalBigFloat ) {
1.1 saito 273: miditvp((Itv)ARG0(arg),&s);
274: *rp = (Obj)s;
275: } else {
276: *rp = (Obj)a;
277: }
278: break;
279: #if 0
280: case O_P:
281: case O_R:
282: case O_LIST:
283: case O_VECT:
284: case O_MAT:
285: #endif
1.5 ! kondoh 286: default:
1.1 saito 287: *rp = (Obj)a;
288: break;
289: }
290: }
291:
292: static void
293: Pcup(NODE arg, Obj *rp)
294: {
295: Itv s;
296: Num a, b;
297:
298: asir_assert(ARG0(arg),O_N,"cup");
299: asir_assert(ARG1(arg),O_N,"cup");
300: a = (Num)ARG0(arg);
301: b = (Num)ARG1(arg);
1.2 kondoh 302: if ( a && NID(a) == N_IntervalDouble && b && NID(b) == N_IntervalDouble ) {
303: cupitvd((IntervalDouble)a, (IntervalDouble)b, (IntervalDouble *)rp);
1.1 saito 304: } else {
305: cupitvp((Itv)ARG0(arg),(Itv)ARG1(arg),&s);
306: *rp = (Obj)s;
307: }
308: }
309:
310: static void
311: Pcap(NODE arg, Obj *rp)
312: {
313: Itv s;
314: Num a, b;
315:
316: asir_assert(ARG0(arg),O_N,"cap");
317: asir_assert(ARG1(arg),O_N,"cap");
318: a = (Num)ARG0(arg);
319: b = (Num)ARG1(arg);
1.2 kondoh 320: if ( a && NID(a) == N_IntervalDouble && b && NID(b) == N_IntervalDouble ) {
321: capitvd((IntervalDouble)a, (IntervalDouble)b, (IntervalDouble *)rp);
1.1 saito 322: } else {
323: capitvp((Itv)ARG0(arg),(Itv)ARG1(arg),&s);
324: *rp = (Obj)s;
325: }
326: }
327:
328: static void
329: Pwidth(arg,rp)
330: NODE arg;
331: Obj *rp;
332: {
333: Num s;
334: Num a;
335:
336: asir_assert(ARG0(arg),O_N,"width");
337: a = (Num)ARG0(arg);
338: if ( ! a ) {
339: *rp = 0;
1.2 kondoh 340: } else if ( NID(a) == N_IntervalDouble ) {
341: widthitvd((IntervalDouble)a, (Num *)rp);
1.1 saito 342: } else {
343: widthitvp((Itv)ARG0(arg),&s);
344: *rp = (Obj)s;
345: }
346: }
347:
348: static void
349: Pabsitv(arg,rp)
350: NODE arg;
351: Obj *rp;
352: {
353: Num s;
354: Num a, b;
355:
356: asir_assert(ARG0(arg),O_N,"absitv");
357: a = (Num)ARG0(arg);
358: if ( ! a ) {
359: *rp = 0;
1.2 kondoh 360: } else if ( NID(a) == N_IntervalDouble ) {
361: absitvd((IntervalDouble)a, (Num *)rp);
1.1 saito 362: } else {
363: absitvp((Itv)ARG0(arg),&s);
364: *rp = (Obj)s;
365: }
366: }
367:
368: static void
369: Pdistance(arg,rp)
370: NODE arg;
371: Obj *rp;
372: {
373: Num s;
374: Num a, b;
375:
376: asir_assert(ARG0(arg),O_N,"distance");
377: asir_assert(ARG1(arg),O_N,"distance");
378: a = (Num)ARG0(arg);
379: b = (Num)ARG1(arg);
1.2 kondoh 380: if ( a && NID(a) == N_IntervalDouble && b && NID(b) == N_IntervalDouble ) {
381: distanceitvd((IntervalDouble)a, (IntervalDouble)b, (Num *)rp);
1.1 saito 382: } else {
383: distanceitvp((Itv)ARG0(arg),(Itv)ARG1(arg),&s);
384: *rp = (Obj)s;
385: }
386: }
387:
388: static void
389: Pinitv(arg,rp)
390: NODE arg;
391: Obj *rp;
392: {
393: int s;
394: Q q;
395:
396: asir_assert(ARG0(arg),O_N,"intval");
397: asir_assert(ARG1(arg),O_N,"intval");
398: if ( ! ARG1(arg) ) {
399: if ( ! ARG0(arg) ) s = 1;
400: else s = 0;
401: }
1.2 kondoh 402: else if ( NID(ARG1(arg)) == N_IntervalDouble ) {
403: s = initvd((Num)ARG0(arg),(IntervalDouble)ARG1(arg));
1.1 saito 404:
1.2 kondoh 405: } else if ( NID(ARG1(arg)) == N_IP || NID(ARG1(arg)) == N_IntervalBigFloat ) {
1.1 saito 406: if ( ! ARG0(arg) ) s = initvp((Num)ARG0(arg),(Itv)ARG1(arg));
407: else if ( NID(ARG0(arg)) == N_IP ) {
408: s = itvinitvp((Itv)ARG0(arg),(Itv)ARG1(arg));
409: } else {
410: s = initvp((Num)ARG0(arg),(Itv)ARG1(arg));
411: }
412: } else {
413: s = ! compnum(0,(Num)ARG0(arg),(Num)ARG1(arg));
414: }
415: STOQ(s,q);
416: *rp = (Obj)q;
417: }
418:
419: static void
420: Pdisjitv(arg,rp)
421: NODE arg;
422: Obj *rp;
423: {
424: Itv s;
425:
426: asir_assert(ARG0(arg),O_N,"disjitv");
427: asir_assert(ARG1(arg),O_N,"disjitv");
428: error("disjitv: not implemented yet");
429: if ( ! s ) *rp = 0;
430: else *rp = (Obj)ONE;
431: }
432:
433: #endif
434: extern int printmode;
435:
436: static void pprintmode( void )
437: {
438: switch (printmode) {
439: #if defined(INTERVAL)
440: case MID_PRINTF_E:
441: fprintf(stderr,"Interval printing mode is a mitpoint type.\n");
442: #endif
443: case PRINTF_E:
444: fprintf(stderr,"Printf's double printing mode is \"%%.16e\".\n");
445: break;
446: #if defined(INTERVAL)
447: case MID_PRINTF_G:
448: fprintf(stderr,"Interval printing mode is a mitpoint type.\n");
449: #endif
450: default:
451: case PRINTF_G:
452: fprintf(stderr,"Printf's double printing mode is \"%%g\".\n");
453: break;
454: }
455: }
456:
457: static void
458: Pprintmode(NODE arg, Obj *rp)
459: {
460: int l;
461: Q a, r;
462:
463: a = (Q)ARG0(arg);
464: if ( !a || NUM(a) && INT(a) ) {
465: l = QTOS(a);
466: if ( l < 0 ) l = 0;
467: #if defined(INTERVAL)
468: else if ( l > MID_PRINTF_E ) l = 0;
469: #else
470: else if ( l > PRINTF_E ) l = 0;
471: #endif
472: STOQ(printmode,r);
473: *rp = (Obj)r;
474: printmode = l;
475: pprintmode();
476: } else {
477: *rp = 0;
478: }
479: }
480:
481: