home *** CD-ROM | disk | FTP | other *** search
/ Club Amiga de Montreal - CAM / CAM_CD_1.iso / files / 564a.lha / igensurf_v1.0 / src.LZH / src / calfunc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-09-28  |  17.0 KB  |  717 lines
  1. /* :ts=8 */
  2. /* Copyright (c) 1986 Regents of the University of California */
  3.  
  4. #include  <stdio.h>
  5. #include  <errno.h>
  6.  
  7. #include  "calcomp.h"
  8. #include  "calc.h"
  9.  
  10.  
  11. #define  ALISTSIZ    6    /* maximum saved argument list */
  12.  
  13. typedef struct Activation_Tag {
  14.     char             *Function_Name; /* function name         */
  15.     struct Activation_Tag  *Prev_Act;       /* previous activation     */
  16.     double             *ArgTab;       /* argument list         */
  17.     unsigned long         ArgFlags;       /* computed argument flags     */
  18.     Expression_T         *Function;       /* argument function     */
  19. }  Activation_T;               /* an activation record     */
  20.  
  21. static Activation_T  *Current_Act = NULL;
  22.  
  23. static double  Func_Exec();
  24.  
  25. #define  MAXLIB        64    /* maximum number of library functions */
  26.  
  27. static double  l_if(), l_select(), l_rand();
  28. static double  l_floor(), l_ceil();
  29. static double  l_sqrt();
  30. static double  l_sin(), l_cos(), l_tan();
  31. static double  l_asin(), l_acos(), l_atan(), l_atan2();
  32. static double  l_exp(), l_log(), l_log10();
  33. static double  l_bezier(), l_bspline();
  34.  
  35. double l_noise3(), l_noise3a(), l_noise3b(), l_noise3c();
  36. double l_hermite(), l_fnoise3();
  37.  
  38.             /* functions must be listed alphabetically */
  39. static Function_T  LibFuncs[MAXLIB] = {
  40.     { "acos",      1, ':', l_acos     },
  41.     { "asin",      1, ':', l_asin     },
  42.     { "atan",      1, ':', l_atan     },
  43.     { "atan2",      2, ':', l_atan2    },
  44.     { "bezier",  5, ':', l_bezier    },
  45.     { "bspline", 5, ':', l_bspline    },
  46.     { "ceil",      1, ':', l_ceil     },
  47.     { "cos",      1, ':', l_cos         },
  48.     { "exp",      1, ':', l_exp         },
  49.     { "floor",      1, ':', l_floor     },
  50.     { "fnoise3", 3, ':', l_fnoise3    },
  51.     { "hermite", 5, ':', l_hermite    },
  52.     { "if",      3, ':', l_if         },
  53.     { "log",      1, ':', l_log         },
  54.     { "log10",      1, ':', l_log10     },
  55.     { "noise3",  3, ':', l_noise3    },
  56.     { "noise3a", 3, ':', l_noise3a    },
  57.     { "noise3b", 3, ':', l_noise3b    },
  58.     { "noise3c", 3, ':', l_noise3c    },
  59.     { "rand",      1, ':', l_rand     },
  60.     { "select",  1, ':', l_select    },
  61.     { "sin",      1, ':', l_sin         },
  62.     { "sqrt",      1, ':', l_sqrt     },
  63.     { "tan",      1, ':', l_tan         },
  64. };    
  65.  
  66.  
  67. static int  Nbr_LibFuncs = 24;
  68.  
  69. extern char  *savestr(), *Emalloc();
  70.  
  71. extern Function_T  *LibFunc_Lookup();
  72.  
  73. extern Variable_T  *Get_Func_Arg();
  74.  
  75. #define  Resolve(Expr)    ( (Expr)->Node_Type == ET_Variable ? \
  76.     (Expr)->Value.Variable : Get_Func_Arg((Expr)->Value.Channel) )
  77.  
  78.  
  79. int Func_Nbr_Args(Function_Name)
  80. char  *Function_Name;
  81. /************************************************************************/
  82. /*                                    */
  83. /* return # of arguments for function                     */
  84. /*                                    */
  85. /************************************************************************/
  86. {
  87.     Function_T  *lp;
  88.     register Variable_T  *vp;
  89.  
  90.     if ((vp = Var_Lookup(Function_Name)) == NULL || 
  91.         vp->Expression == NULL || 
  92.     vp->Expression->Value.Kid->Node_Type != ET_Function) {
  93.  
  94.     if ((lp = LibFunc_Lookup(Function_Name)) == NULL) return(0);
  95.     else return( (int) lp->Number_Args);
  96.  
  97.     } else  return(Nbr_Kids(vp->Expression->Value.Kid) - 1);
  98.  
  99. } /* Func_Nbr_Args */
  100.  
  101.  
  102. double Func_Value(Function_Name, n, ArgTab)    
  103. char  *Function_Name;
  104. int  n;
  105. double  *ArgTab;
  106. /************************************************************************/
  107. /*                                    */
  108. /* return a function value to the user                     */
  109. /*                                    */
  110. /************************************************************************/
  111. {
  112.     Activation_T       Activation_Record;
  113.     register Variable_T  *vp;
  114.     double           rval;
  115.                     /* push environment */
  116.     Activation_Record.Function_Name     = Function_Name;
  117.     Activation_Record.Prev_Act         = Current_Act;
  118.     Activation_Record.ArgTab           = ArgTab;
  119.     Activation_Record.ArgFlags         = (1L<<n)-1;
  120.     Activation_Record.Function         = NULL;
  121.  
  122.     Current_Act     = &Activation_Record;
  123.  
  124.     if ((vp = Var_Lookup(Function_Name)) == NULL || 
  125.         vp->Expression == NULL || 
  126.     vp->Expression->Value.Kid->Node_Type != ET_Function) {
  127.  
  128.      rval = Func_Exec(Function_Name, vp);
  129.  
  130.     } else {
  131.  
  132.         rval = Expr_Value(vp->Expression->Value.Kid->Sibling);
  133.  
  134.     }
  135.  
  136.     Current_Act = Activation_Record.Prev_Act;    /* pop environment */
  137.  
  138.     return(rval);
  139.  
  140. } /* Func_Value */
  141.  
  142.  
  143. void Func_Set(Function_Name, Number_Args, Assignment_Type, Func_Ptr)
  144. char      *Function_Name;
  145. int      Number_Args;
  146. int      Assignment_Type;
  147. double  (*Func_Ptr)();
  148. /************************************************************************/
  149. /*                                    */
  150. /* set a library function                         */
  151. /*                                    */
  152. /************************************************************************/
  153. {
  154.     register Function_T  *Fp;
  155.  
  156.     if ((Fp = LibFunc_Lookup(Function_Name)) == NULL) {
  157.  
  158.     if (Nbr_LibFuncs >= MAXLIB) {
  159.  
  160.         fprintf(stderr, "Too many library functions!\n");
  161.         exit(1);
  162.  
  163.     }
  164.  
  165.     for (Fp = &LibFuncs[Nbr_LibFuncs]; Fp > LibFuncs; Fp--)
  166.  
  167.         if (strcmp(Fp[-1].Function_Name, Function_Name) > 0) {
  168.  
  169.         Fp[0].Function_Name   = Fp[-1].Function_Name;
  170.         Fp[0].Number_Args     = Fp[-1].Number_Args;
  171.         Fp[0].Assignment_Type = Fp[-1].Assignment_Type;
  172.         Fp[0].Func_Ptr        = Fp[-1].Func_Ptr;
  173.  
  174.         } else break;
  175.  
  176.     Nbr_LibFuncs++;
  177.  
  178.     } /* if */
  179.  
  180.     Fp[0].Function_Name   = savestr(Function_Name);
  181.     Fp[0].Number_Args       = Number_Args;
  182.     Fp[0].Assignment_Type = Assignment_Type;
  183.     Fp[0].Func_Ptr       = Func_Ptr;
  184.  
  185. } /* Func_Set */
  186.  
  187.  
  188. int Get_Nbr_Args()
  189. /************************************************************************/
  190. /*                                    */
  191. /* return number of available arguments                 */
  192. /*                                    */
  193. /************************************************************************/
  194. {
  195.     register int  n;
  196.  
  197.     if (Current_Act == NULL) return(0);
  198.  
  199.     if (Current_Act->Function == NULL) {
  200.  
  201.     for (n = 0; (1L<<n) & Current_Act->ArgFlags; n++) ;
  202.     return(n);
  203.  
  204.     } /* if */
  205.  
  206.     return(Nbr_Kids(Current_Act->Function) - 1);
  207.  
  208. } /* Get_Nbr_Args */
  209.  
  210.  
  211. double Get_Argument(n)
  212. register int  n;
  213. /************************************************************************/
  214. /*                                    */
  215. /* return nth argument for active function                 */
  216. /*                                    */
  217. /************************************************************************/
  218. {
  219.     register Activation_T  *actp = Current_Act;
  220.     Expression_T  *Expr;
  221.     double  aval;
  222.  
  223.     if (actp == NULL || --n < 0) {
  224.  
  225.     fprintf(stderr, "Bad call to Get_Argument!\n");
  226.     exit(1);
  227.  
  228.     } /* if */
  229.                         /* already computed? */
  230.     if (1L<<n & actp->ArgFlags) return(actp->ArgTab[n]);
  231.  
  232.     if (actp->Function == NULL || 
  233.         (Expr = Expr_Kid(actp->Function, n+1)) == NULL) {
  234.  
  235.     fprintf(stderr, "%s : too few arguments\n", actp->Function_Name);
  236.     exit(1);
  237.  
  238.     } /* if */
  239.  
  240.     Current_Act = actp->Prev_Act;        /* pop environment */
  241.     aval = Expr_Value(Expr);            /* compute argument */
  242.     Current_Act = actp;                /* push back environment */
  243.  
  244.     if (n < ALISTSIZ) {                /* save value */
  245.  
  246.     actp->ArgTab[n] = aval;
  247.     actp->ArgFlags |= 1L<<n;
  248.  
  249.     }
  250.  
  251.     return(aval);
  252.  
  253. } /* Get_Argument */
  254.  
  255.  
  256. Variable_T *Get_Func_Arg(n)
  257. int  n;
  258. /************************************************************************/
  259. /*                                    */
  260. /* return function def for nth argument                 */
  261. /*                                    */
  262. /************************************************************************/
  263. {
  264.     register Activation_T  *actp;
  265.     register Expression_T  *Expr;
  266.  
  267.     for (actp = Current_Act; actp != NULL; actp = actp->Prev_Act) {
  268.  
  269.     if (n <= 0) break;
  270.  
  271.     if (actp->Function == NULL) goto badarg;
  272.  
  273.     if ((Expr = Expr_Kid(actp->Function, n)) == NULL) {
  274.  
  275.         fprintf(stderr, "%s : too few arguments\n", actp->Function_Name);
  276.         exit(1);
  277.  
  278.     } /* if */
  279.  
  280.     if (Expr->Node_Type == ET_Variable) return(Expr->Value.Variable);
  281.  
  282.     if (Expr->Node_Type != ET_Argument) goto badarg;
  283.  
  284.     n = Expr->Value.Channel;        /* try previous context */
  285.  
  286.     } /* for */
  287.  
  288.     fprintf(stderr, "Bad call to Get_Func_Arg!\n");
  289.  
  290.     exit(1);
  291.  
  292. badarg:
  293.     fprintf(stderr, "%s : argument not a function\n", actp->Function_Name);
  294.     exit(1);
  295.  
  296. } /* Get_Func_Arg */
  297.  
  298.  
  299. char *Get_Func_Arg_Name(n)    
  300. int  n;
  301. /************************************************************************/
  302. /*                                    */
  303. /* return function name for nth argument                 */
  304. /*                                    */
  305. /************************************************************************/
  306. {
  307.     return(Get_Func_Arg(n)->Name);
  308.  
  309. } /* Get_Func_Arg_Name */
  310.  
  311.  
  312. double EFunc_Function(Expr)
  313. register Expression_T  *Expr;
  314. /************************************************************************/
  315. /*                                    */
  316. /* evaluate a function                             */
  317. /*                                    */
  318. /************************************************************************/
  319. {
  320.     Activation_T       act;
  321.     double           alist[ALISTSIZ];
  322.     double           rval;
  323.     register Variable_T  *dp;
  324.                     /* push environment */
  325.     dp = Resolve(Expr->Value.Kid);
  326.  
  327.     act.Function_Name     = dp->Name;
  328.     act.Prev_Act     = Current_Act;
  329.     act.ArgTab         = alist;
  330.     act.ArgFlags     = 0;
  331.     act.Function     = Expr;
  332.  
  333.     Current_Act = &act;
  334.  
  335.     if (dp->Expression == NULL || 
  336.         dp->Expression->Value.Kid->Node_Type != ET_Function) {
  337.  
  338.     rval = Func_Exec(act.Function_Name, dp);
  339.  
  340.     } else {
  341.  
  342.     rval = Expr_Value(dp->Expression->Value.Kid->Sibling);
  343.  
  344.     } 
  345.  
  346.     Current_Act = act.Prev_Act;            /* pop environment */
  347.  
  348.     return(rval);
  349.  
  350. } /* EFunc_Function */
  351.  
  352.  
  353. Function_T *LibFunc_Lookup(Function_Name)
  354. char  *Function_Name;
  355. /************************************************************************/
  356. /*                                    */
  357. /* look up a library function                         */
  358. /*                                    */
  359. /************************************************************************/
  360. {
  361.     int  upper, lower;
  362.     register int  cm, i;
  363.  
  364.     lower = 0;
  365.     upper = cm = Nbr_LibFuncs;
  366.  
  367.     while ((i = (lower + upper) >> 1) != cm) {
  368.  
  369.     cm = strcmp(Function_Name, LibFuncs[i].Function_Name);
  370.  
  371.     if (cm > 0)      lower = i;
  372.     else if (cm < 0) upper = i;
  373.     else          return(&LibFuncs[i]);
  374.  
  375.     cm = i;
  376.  
  377.     } /* while */
  378.  
  379.     return(NULL);
  380.  
  381. } /* LibFunc_Lookup */
  382.  
  383. static double Func_Exec(Function_Name, vp)    
  384. char               *Function_Name;
  385. register Variable_T  *vp;
  386. /************************************************************************/
  387. /*                                    */
  388. /* execute library function                         */
  389. /*                                    */
  390. /************************************************************************/
  391. {
  392.     Variable_T  dumdef;
  393.     double      d;
  394.     int      lasterrno;
  395.  
  396.     if (vp == NULL) {
  397.  
  398.     vp = &dumdef;
  399.     vp->Function = NULL;
  400.  
  401.     } /* if */
  402.  
  403.     if (
  404.          (
  405.             (vp->Function == NULL || 
  406.          strcmp(Function_Name, vp->Function->Function_Name)) && 
  407.         (vp->Function = LibFunc_Lookup(Function_Name)) == NULL
  408.     ) ||  vp->Function->Func_Ptr == NULL
  409.  
  410.        ) {
  411.  
  412.     fprintf(stderr, "%s : undefined function\n", Function_Name);
  413.     exit(1);
  414.     }
  415.  
  416.     lasterrno = errno;
  417.     errno     = 0;
  418.  
  419.     d = (*vp->Function->Func_Ptr)();
  420.  
  421. #ifdef  IEEE
  422.     if (!finite(d)) errno = EDOM;
  423. #endif
  424.  
  425.     if (errno) {
  426.     fprintf(stderr, "%s : bad call\n", Function_Name);
  427.     return(0.0);
  428.     }
  429.     errno = lasterrno;
  430.     return(d);
  431. }
  432.  
  433.  
  434. /*
  435.  *  Library functions:
  436.  */
  437.  
  438.  
  439. static double l_if()        
  440. /************************************************************************/
  441. /*                                    */
  442. /* if(cond, then, else) conditional expression                */
  443. /* cond evaluates true if greater than zero                 */
  444. /*                                    */
  445. /************************************************************************/
  446. {
  447.     if (Get_Argument(1) > 0.0) return(Get_Argument(2));
  448.     else                return(Get_Argument(3));
  449.  
  450. } /* l_if */
  451.  
  452.  
  453. static double l_select()
  454. /************************************************************************/
  455. /*                                    */
  456. /* return argument #(A1+1)                         */
  457. /*                                    */
  458. /************************************************************************/
  459. {
  460.     register int  n;
  461.  
  462.     n = Get_Argument(1) + .5;
  463.  
  464.     if (n == 0) return( (double) (Get_Nbr_Args()-1) );
  465.  
  466.     if (n < 1 || n > Get_Nbr_Args()-1) {
  467.  
  468.     errno = EDOM;
  469.     return(0.0);
  470.  
  471.     } /* if */
  472.  
  473.     return(Get_Argument(n+1));
  474.  
  475. } /* l_select */
  476.  
  477.  
  478. static double l_rand()    
  479. /************************************************************************/
  480. /*                                    */
  481. /* random function between 0 and 1                     */
  482. /*                                    */
  483. /************************************************************************/
  484. {
  485.     extern double  floor();
  486.     double  x;
  487.  
  488.     x = Get_Argument(1);
  489.     x *= 1.0/(1.0 + x*x) + 2.71828182845904;
  490.     x += .785398163397447 - floor(x);
  491.     x = 1e5 / x;
  492.  
  493.     return(x - floor(x));
  494.  
  495. } /* l_rand */
  496.  
  497.  
  498. static double l_floor()
  499. /************************************************************************/
  500. /*                                    */
  501. /* return largest integer not greater than arg1             */
  502. /*                                    */
  503. /************************************************************************/
  504. {
  505.     extern double  floor();
  506.  
  507.     return(floor(Get_Argument(1)));
  508.  
  509. } /* l_floor */
  510.  
  511.  
  512. static double l_ceil()
  513. /************************************************************************/
  514. /*                                    */
  515. /* return smallest integer not less than arg1                 */
  516. /*                                    */
  517. /************************************************************************/
  518. {
  519.     extern double  ceil();
  520.  
  521.     return(ceil(Get_Argument(1)));
  522.  
  523. } /* l_ceil */
  524.  
  525.  
  526. static double l_sqrt()
  527. /************************************************************************/
  528. /*                                    */
  529. /*                                    */
  530. /************************************************************************/
  531. {
  532.     extern double  sqrt();
  533.  
  534.     return(sqrt(Get_Argument(1)));
  535.  
  536. } /* l_sqrt */
  537.  
  538.  static double l_sin()
  539. /************************************************************************/
  540. /*                                    */
  541. /*                                    */
  542. /************************************************************************/
  543. {
  544.     extern double  sin();
  545.  
  546.     return(sin(Get_Argument(1)));
  547.  
  548. } /* l_sin */
  549.  
  550.  
  551. static double l_cos()
  552. /************************************************************************/
  553. /*                                    */
  554. /*                                    */
  555. /************************************************************************/
  556. {
  557.     extern double  cos();
  558.  
  559.     return(cos(Get_Argument(1)));
  560.  
  561. } /* l_cos */
  562.  
  563.  
  564. static double l_tan()
  565. /************************************************************************/
  566. /*                                    */
  567. /*                                    */
  568. /************************************************************************/
  569. {
  570.     extern double  tan();
  571.  
  572.     return(tan(Get_Argument(1)));
  573.  
  574. } /* l_tan */
  575.  
  576.  
  577. static double l_asin()
  578. /************************************************************************/
  579. /*                                    */
  580. /*                                    */
  581. /************************************************************************/
  582. {
  583.     extern double  asin();
  584.  
  585.     return(asin(Get_Argument(1)));
  586.  
  587. } /* l_asin */
  588.  
  589.  
  590. static double l_acos()
  591. /************************************************************************/
  592. /*                                    */
  593. /*                                    */
  594. /************************************************************************/
  595. {
  596.     extern double  acos();
  597.  
  598.     return(acos(Get_Argument(1)));
  599.  
  600. } /* l_acos */
  601.  
  602.  
  603. static double l_atan()
  604. /************************************************************************/
  605. /*                                    */
  606. /*                                    */
  607. /************************************************************************/
  608. {
  609.     extern double  atan();
  610.  
  611.     return(atan(Get_Argument(1)));
  612.  
  613. } /* l_atan */
  614.  
  615.  
  616. static double l_atan2()
  617. /************************************************************************/
  618. /*                                    */
  619. /*                                    */
  620. /************************************************************************/
  621. {
  622.     extern double  atan2();
  623.  
  624.     return(atan2(Get_Argument(1), Get_Argument(2)));
  625.  
  626. } /* l_atan2 */
  627.  
  628.  
  629. static double l_exp()
  630. /************************************************************************/
  631. /*                                    */
  632. /*                                    */
  633. /************************************************************************/
  634. {
  635.     extern double  exp();
  636.  
  637.     return(exp(Get_Argument(1)));
  638.  
  639. } /* l_exp */
  640.  
  641.  
  642. static double l_log()
  643. /************************************************************************/
  644. /*                                    */
  645. /*                                    */
  646. /************************************************************************/
  647. {
  648.     extern double  log();
  649.  
  650.     return(log(Get_Argument(1)));
  651.  
  652. } /* l_log */
  653.  
  654.  
  655. static double l_log10()
  656. /************************************************************************/
  657. /*                                    */
  658. /*                                    */
  659. /************************************************************************/
  660. {
  661.     extern double  log10();
  662.  
  663.     return(log10(Get_Argument(1)));
  664.  
  665. } /* l_log10 */
  666.  
  667.  
  668. double l_bezier()
  669. /************************************************************************/
  670. /*                                    */
  671. /* The bezier function:                            */
  672. /*                                    */
  673. /* b(P1, P2, P3, P4, t) = P1 * (1-t)^3 +                 */
  674. /*                       P2 * 3 * t * (1-t)^2 +             */
  675. /*                       P3 * 3 * t^2 * (1-t) +             */
  676. /*                       P4 * t^3                     */
  677. /*                                    */
  678. /* Characteristics:                            */
  679. /*                                    */
  680. /* b(0) = P0     db/dt(0) = 3(P2-P1)                    */
  681. /* b(1) = P4    db/dt(1) = 3(P4-P3)                    */
  682. /*                                    */
  683. /* ie. a bezier curve passes through P0 with a tangent in the direction    */
  684. /* of P1. It passes through P4 with a tangent from the direction of P3.    */
  685. /*                                    */
  686. /************************************************************************/
  687. {
  688.     double  t;
  689.     double    Get_Argument();
  690.  
  691.     t = Get_Argument(5);
  692.     return(Get_Argument(1) * (1.+t*(-3.+t*(3.-t))) +
  693.        Get_Argument(2) * 3.*t*(1.+t*(-2.+t)) +
  694.        Get_Argument(3) * 3.*t*t*(1.-t) +
  695.        Get_Argument(4) * t*t*t );
  696.  
  697. } /* l_bezier */
  698.  
  699.  
  700. double l_bspline()
  701. /************************************************************************/
  702. /*                                    */
  703. /* The bspline function.                        */
  704. /*                                    */
  705. /************************************************************************/
  706. {
  707.     double  t;
  708.     double    Get_Argument();
  709.  
  710.     t = Get_Argument(5);
  711.     return(Get_Argument(1) * (1./6.+t*(-1./2.+t*(1./2.-1./6.*t))) +
  712.        Get_Argument(2) * (2./3.+t*t*(-1.+1./2.*t)) +
  713.        Get_Argument(3) * (1./6.+t*(1./2.+t*(1./2.-1./2.*t))) +
  714.        Get_Argument(4) * (1./6.*t*t*t) );
  715.  
  716. } /* l_bspline */
  717.