[BACK]Return to itvnum.c CVS log [TXT][DIR] Up to [local] / OpenXM_contrib2 / asir2000 / builtin

Annotation of OpenXM_contrib2/asir2000/builtin/itvnum.c, Revision 1.2

1.1       saito       1: /*
1.2     ! kondoh      2:  * $OpenXM: OpenXM_contrib2/asir2000/builtin/itvnum.c,v 1.1 2000/12/22 09:58:32 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 *);
                     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:                }
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;
                    212:                        defaults:
                    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;
                    244:                        defaults:
                    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
                    286:                defaults:
                    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:

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>