![[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: /*
! 2: * $OpenXM: $
! 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 *);
! 24: static void Pitvversion(Obj *);
! 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
! 59: Pitvversion(Obj *rp)
! 60: {
! 61: STOQ(ASIR_VERSION,(Q)*rp);
! 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: }
! 89: else if ( NID(a) == N_IP || NID(a) == N_IF) {
! 90: *rp = (Obj)a;
! 91: return;
! 92: }
! 93: else if ( NID(a) == N_ID ) {
! 94: inf = INF((ItvD)a);
! 95: sup = SUP((ItvD)a);
! 96: double2bf(inf, (BF *)&i);
! 97: double2bf(sup, (BF *)&s);
! 98: istoitv(i,s,&c);
! 99: }
! 100: else istoitv(a,a,&c);
! 101: }
! 102: if ( NID( c ) == N_IF ) addulp((ItvF)c, (ItvF *)rp);
! 103: else *rp = (Obj)c;
! 104: #endif
! 105: }
! 106:
! 107: static void
! 108: Pitvbf(NODE arg, Obj *rp)
! 109: {
! 110: Num a, i, s;
! 111: Itv c;
! 112: BF ii,ss;
! 113: double inf, sup;
! 114:
! 115: asir_assert(ARG0(arg),O_N,"intvalbf");
! 116: a = (Num)ARG0(arg);
! 117: if ( argc(arg) > 1 ) {
! 118: asir_assert(ARG1(arg),O_N,"intvalbf");
! 119: i = (Num)ARG0(arg);
! 120: s = (Num)ARG1(arg);
! 121: ToBf(i, &ii);
! 122: ToBf(s, &ss);
! 123: istoitv((Num)ii,(Num)ss,&c);
! 124: } else {
! 125: if ( ! a ) {
! 126: *rp = 0;
! 127: return;
! 128: }
! 129: else if ( NID(a) == N_IP ) {
! 130: itvtois((Itv)a, &i, &s);
! 131: ToBf(i, &ii);
! 132: ToBf(s, &ss);
! 133: istoitv((Num)ii,(Num)ss,&c);
! 134: }
! 135: else if ( NID(a) == N_IF) {
! 136: *rp = (Obj)a;
! 137: return;
! 138: }
! 139: else if ( NID(a) == N_ID ) {
! 140: inf = INF((ItvD)a);
! 141: sup = SUP((ItvD)a);
! 142: double2bf(inf, (BF *)&i);
! 143: double2bf(sup, (BF *)&s);
! 144: istoitv(i,s,&c);
! 145: }
! 146: else {
! 147: ToBf(a, (BF *)&i);
! 148: istoitv(i,i,&c);
! 149: }
! 150: }
! 151: if ( c && OID( c ) == O_N && NID( c ) == N_IF ) addulp((ItvF)c, (ItvF *)rp);
! 152: else *rp = (Obj)c;
! 153: }
! 154:
! 155: static void
! 156: Pitvd(NODE arg, Obj *rp)
! 157: {
! 158: double inf, sup;
! 159: Num a, a0, a1, t;
! 160: Itv ia;
! 161: ItvD d;
! 162:
! 163: asir_assert(ARG0(arg),O_N,"intvald");
! 164: a0 = (Num)ARG0(arg);
! 165: if ( argc(arg) > 1 ) {
! 166: asir_assert(ARG1(arg),O_N,"intvald");
! 167: a1 = (Num)ARG1(arg);
! 168: } else {
! 169: if ( a0 && OID(a0)==O_N && NID(a0)==N_ID ) {
! 170: inf = INF((ItvD)a0);
! 171: sup = SUP((ItvD)a0);
! 172: MKItvD(inf,sup,d);
! 173: *rp = (Obj)d;
! 174: return;
! 175: }
! 176: a1 = (Num)ARG0(arg);
! 177: }
! 178: if ( compnum(0,a0,a1) > 0 ) {
! 179: t = a0; a0 = a1; a1 = t;
! 180: }
! 181: inf = ToRealDown(a0);
! 182: sup = ToRealUp(a1);
! 183: MKItvD(inf,sup,d);
! 184: *rp = (Obj)d;
! 185: }
! 186:
! 187: static void
! 188: Pinf(NODE arg, Obj *rp)
! 189: {
! 190: Num a, i, s;
! 191: Real r;
! 192: double d;
! 193:
! 194: a = (Num)ARG0(arg);
! 195: if ( ! a ) {
! 196: *rp = 0;
! 197: } else if ( OID(a) == O_N ) {
! 198: switch ( NID(a) ) {
! 199: case N_ID:
! 200: d = INF((ItvD)a);
! 201: MKReal(d, r);
! 202: *rp = (Obj)r;
! 203: break;
! 204: case N_IP:
! 205: case N_IF:
! 206: case N_IT:
! 207: itvtois((Itv)ARG0(arg),&i,&s);
! 208: *rp = (Obj)i;
! 209: break;
! 210: defaults:
! 211: *rp = (Obj)a;
! 212: break;
! 213: }
! 214: } else {
! 215: *rp = (Obj)a;
! 216: }
! 217: }
! 218:
! 219: static void
! 220: Psup(NODE arg, Obj *rp)
! 221: {
! 222: Num a, i, s;
! 223: Real r;
! 224: double d;
! 225:
! 226: a = (Num)ARG0(arg);
! 227: if ( ! a ) {
! 228: *rp = 0;
! 229: } else if ( OID(a) == O_N ) {
! 230: switch ( NID(a) ) {
! 231: case N_ID:
! 232: d = SUP((ItvD)a);
! 233: MKReal(d, r);
! 234: *rp = (Obj)r;
! 235: break;
! 236: case N_IP:
! 237: case N_IF:
! 238: case N_IT:
! 239: itvtois((Itv)ARG0(arg),&i,&s);
! 240: *rp = (Obj)s;
! 241: break;
! 242: defaults:
! 243: *rp = (Obj)a;
! 244: break;
! 245: }
! 246: } else {
! 247: *rp = (Obj)a;
! 248: }
! 249: }
! 250:
! 251: static void
! 252: Pmid(NODE arg, Obj *rp)
! 253: {
! 254: Num a, s;
! 255: Real r;
! 256: double d;
! 257:
! 258: a = (Num)ARG0(arg);
! 259: if ( ! a ) {
! 260: *rp = 0;
! 261: } else switch (OID(a)) {
! 262: case O_N:
! 263: if ( NID(a) == N_ID ) {
! 264: d = ( INF((ItvD)a)+SUP((ItvD)a) ) / 2.0;
! 265: MKReal(d, r);
! 266: *rp = (Obj)r;
! 267: } else if ( NID(a) == N_IT ) {
! 268: error("mid: not supported operation");
! 269: *rp = 0;
! 270: } else if ( NID(a) == N_IP || NID(a) == N_IF ) {
! 271: miditvp((Itv)ARG0(arg),&s);
! 272: *rp = (Obj)s;
! 273: } else {
! 274: *rp = (Obj)a;
! 275: }
! 276: break;
! 277: #if 0
! 278: case O_P:
! 279: case O_R:
! 280: case O_LIST:
! 281: case O_VECT:
! 282: case O_MAT:
! 283: #endif
! 284: defaults:
! 285: *rp = (Obj)a;
! 286: break;
! 287: }
! 288: }
! 289:
! 290: static void
! 291: Pcup(NODE arg, Obj *rp)
! 292: {
! 293: Itv s;
! 294: Num a, b;
! 295:
! 296: asir_assert(ARG0(arg),O_N,"cup");
! 297: asir_assert(ARG1(arg),O_N,"cup");
! 298: a = (Num)ARG0(arg);
! 299: b = (Num)ARG1(arg);
! 300: if ( a && NID(a) == N_ID && b && NID(b) == N_ID ) {
! 301: cupitvd((ItvD)a, (ItvD)b, (ItvD *)rp);
! 302: } else {
! 303: cupitvp((Itv)ARG0(arg),(Itv)ARG1(arg),&s);
! 304: *rp = (Obj)s;
! 305: }
! 306: }
! 307:
! 308: static void
! 309: Pcap(NODE arg, Obj *rp)
! 310: {
! 311: Itv s;
! 312: Num a, b;
! 313:
! 314: asir_assert(ARG0(arg),O_N,"cap");
! 315: asir_assert(ARG1(arg),O_N,"cap");
! 316: a = (Num)ARG0(arg);
! 317: b = (Num)ARG1(arg);
! 318: if ( a && NID(a) == N_ID && b && NID(b) == N_ID ) {
! 319: capitvd((ItvD)a, (ItvD)b, (ItvD *)rp);
! 320: } else {
! 321: capitvp((Itv)ARG0(arg),(Itv)ARG1(arg),&s);
! 322: *rp = (Obj)s;
! 323: }
! 324: }
! 325:
! 326: static void
! 327: Pwidth(arg,rp)
! 328: NODE arg;
! 329: Obj *rp;
! 330: {
! 331: Num s;
! 332: Num a;
! 333:
! 334: asir_assert(ARG0(arg),O_N,"width");
! 335: a = (Num)ARG0(arg);
! 336: if ( ! a ) {
! 337: *rp = 0;
! 338: } else if ( NID(a) == N_ID ) {
! 339: widthitvd((ItvD)a, (Num *)rp);
! 340: } else {
! 341: widthitvp((Itv)ARG0(arg),&s);
! 342: *rp = (Obj)s;
! 343: }
! 344: }
! 345:
! 346: static void
! 347: Pabsitv(arg,rp)
! 348: NODE arg;
! 349: Obj *rp;
! 350: {
! 351: Num s;
! 352: Num a, b;
! 353:
! 354: asir_assert(ARG0(arg),O_N,"absitv");
! 355: a = (Num)ARG0(arg);
! 356: if ( ! a ) {
! 357: *rp = 0;
! 358: } else if ( NID(a) == N_ID ) {
! 359: absitvd((ItvD)a, (Num *)rp);
! 360: } else {
! 361: absitvp((Itv)ARG0(arg),&s);
! 362: *rp = (Obj)s;
! 363: }
! 364: }
! 365:
! 366: static void
! 367: Pdistance(arg,rp)
! 368: NODE arg;
! 369: Obj *rp;
! 370: {
! 371: Num s;
! 372: Num a, b;
! 373:
! 374: asir_assert(ARG0(arg),O_N,"distance");
! 375: asir_assert(ARG1(arg),O_N,"distance");
! 376: a = (Num)ARG0(arg);
! 377: b = (Num)ARG1(arg);
! 378: if ( a && NID(a) == N_ID && b && NID(b) == N_ID ) {
! 379: distanceitvd((ItvD)a, (ItvD)b, (Num *)rp);
! 380: } else {
! 381: distanceitvp((Itv)ARG0(arg),(Itv)ARG1(arg),&s);
! 382: *rp = (Obj)s;
! 383: }
! 384: }
! 385:
! 386: static void
! 387: Pinitv(arg,rp)
! 388: NODE arg;
! 389: Obj *rp;
! 390: {
! 391: int s;
! 392: Q q;
! 393:
! 394: asir_assert(ARG0(arg),O_N,"intval");
! 395: asir_assert(ARG1(arg),O_N,"intval");
! 396: if ( ! ARG1(arg) ) {
! 397: if ( ! ARG0(arg) ) s = 1;
! 398: else s = 0;
! 399: }
! 400: else if ( NID(ARG1(arg)) == N_ID ) {
! 401: s = initvd((Num)ARG0(arg),(ItvD)ARG1(arg));
! 402:
! 403: } else if ( NID(ARG1(arg)) == N_IP || NID(ARG1(arg)) == N_IF ) {
! 404: if ( ! ARG0(arg) ) s = initvp((Num)ARG0(arg),(Itv)ARG1(arg));
! 405: else if ( NID(ARG0(arg)) == N_IP ) {
! 406: s = itvinitvp((Itv)ARG0(arg),(Itv)ARG1(arg));
! 407: } else {
! 408: s = initvp((Num)ARG0(arg),(Itv)ARG1(arg));
! 409: }
! 410: } else {
! 411: s = ! compnum(0,(Num)ARG0(arg),(Num)ARG1(arg));
! 412: }
! 413: STOQ(s,q);
! 414: *rp = (Obj)q;
! 415: }
! 416:
! 417: static void
! 418: Pdisjitv(arg,rp)
! 419: NODE arg;
! 420: Obj *rp;
! 421: {
! 422: Itv s;
! 423:
! 424: asir_assert(ARG0(arg),O_N,"disjitv");
! 425: asir_assert(ARG1(arg),O_N,"disjitv");
! 426: error("disjitv: not implemented yet");
! 427: if ( ! s ) *rp = 0;
! 428: else *rp = (Obj)ONE;
! 429: }
! 430:
! 431: #endif
! 432: extern int printmode;
! 433:
! 434: static void pprintmode( void )
! 435: {
! 436: switch (printmode) {
! 437: #if defined(INTERVAL)
! 438: case MID_PRINTF_E:
! 439: fprintf(stderr,"Interval printing mode is a mitpoint type.\n");
! 440: #endif
! 441: case PRINTF_E:
! 442: fprintf(stderr,"Printf's double printing mode is \"%%.16e\".\n");
! 443: break;
! 444: #if defined(INTERVAL)
! 445: case MID_PRINTF_G:
! 446: fprintf(stderr,"Interval printing mode is a mitpoint type.\n");
! 447: #endif
! 448: default:
! 449: case PRINTF_G:
! 450: fprintf(stderr,"Printf's double printing mode is \"%%g\".\n");
! 451: break;
! 452: }
! 453: }
! 454:
! 455: static void
! 456: Pprintmode(NODE arg, Obj *rp)
! 457: {
! 458: int l;
! 459: Q a, r;
! 460:
! 461: a = (Q)ARG0(arg);
! 462: if ( !a || NUM(a) && INT(a) ) {
! 463: l = QTOS(a);
! 464: if ( l < 0 ) l = 0;
! 465: #if defined(INTERVAL)
! 466: else if ( l > MID_PRINTF_E ) l = 0;
! 467: #else
! 468: else if ( l > PRINTF_E ) l = 0;
! 469: #endif
! 470: STOQ(printmode,r);
! 471: *rp = (Obj)r;
! 472: printmode = l;
! 473: pprintmode();
! 474: } else {
! 475: *rp = 0;
! 476: }
! 477: }
! 478:
! 479: