func_t *func_set_script(func_t *f) { strings *a=NULL,*b=NULL,*vlist=NULL; func_t *g=NULL; if(func_is_strings(f) && func_strings_size(f)==1){ if(str_match(func_strings_at(f,0),"=",BLK0,BLK1)){ a=strings_split(func_strings_at(f,0),"=",BLK0,BLK1,SPC); if(strings_size(a)==2 && str_match(strings_at(a,0),"^%A%I*$",BLK0,BLK1)){ g=func_set(func_def(strings_at(a,0),func_script(strings_at(a,1)),0,FUNC_NOLIMIT)); }else if(strings_size(a)==2 && str_match(strings_at(a,0),"^%A%I*(%m*)$",BLK0,BLK1)){ b=strings_split_mask(strings_at(a,0),BLK0,BLK1,SPC); if(strings_size(b)==1){ g=func_set(func_def(strings_at(b,0),func_script(strings_at(a,1)),0,0)); }else if(strings_size(b)>1){ vlist=strings_split(strings_at(b,1),",",BLK0,BLK1,SPC); func_scope_begin(func_strings_strings(vlist)); g=func_set(func_def(strings_at(b,0),func_eval(func_script(strings_at(a,1))),strings_size(vlist),strings_size(vlist))); func_scope_end(); } } } } if(g==NULL){ g=f; }else{ f=func_del(f); } a=strings_del(a); b=strings_del(b); vlist=strings_del(vlist); return g; }
TAMObject *core_eval (TAMObject *arguments, void *data, TAMEnv *env) { LispCoreData *d = data; TAMObject *arg1; ASSERT(arguments); ASSERT(data); ASSERT(env); ASSERT(arguments == d->arg_list_cache_1); arg1 = tam_env_symbol_lookup(env, d->arg1); ASSERT(arg1); return func_eval(arg1, env); }
cons_t sgmt_eval(cons_t * cell) { cons_t result = { 0, {NULL}, NULL }; switch (cell->type) { case START: if (cell->car->type == SYMBOL) { cell->car->type = FUNC; } result = sgmt_eval(cell->car); break; case INT: result.ivalue = cell->ivalue; break; case T: result.type = T; case NIL: result.type = NIL; case IF: result = if_eval(cell, result); break; case FUNC: result = func_eval(cell, result); break; case ARG:{ int i = 0; int tmp_arg = ftable[hash(func_name_tmp)]->argsize; for (i = 0; i < tmp_arg; i++) { if (ftable[hash(func_name_tmp)]->arg_name[i] != '\0' && strncmp(cell->symbol, ftable[hash(func_name_tmp)]->arg_name[i], sizeof(cell->symbol)) == 0) { result.ivalue = arg_s[i][stack_num - 1]; } } break; } case PLUS: while (cell->cdr != NULL) { result.ivalue += sgmt_eval(cell->cdr).ivalue; cell = cell->cdr; } break; case MINUS: if (cell->cdr != NULL && cell->cdr->cdr != NULL) { result.ivalue = sgmt_eval(cell->cdr).ivalue; } else { result.ivalue = -sgmt_eval(cell->cdr).ivalue; } cell = cell->cdr; while (cell->cdr != NULL) { result.ivalue -= sgmt_eval(cell->cdr).ivalue; cell = cell->cdr; } break; case MULTI: result.ivalue = 1; while (cell->cdr != NULL) { result.ivalue = result.ivalue * sgmt_eval(cell->cdr).ivalue; cell = cell->cdr; } break; case DIVID: result.ivalue = sgmt_eval(cell->cdr).ivalue; cell = cell->cdr; int div; while (cell->cdr != NULL) { div = sgmt_eval(cell->cdr).ivalue; if (div == 0) { printf("division by zero !\n"); result.ivalue = 0; result.car = NULL; result.cdr = NULL; break; } result.ivalue /= div; cell = cell->cdr; } break; case GT: cell = cell->cdr; while (cell->cdr != NULL) { if (sgmt_eval(cell).ivalue <= sgmt_eval(cell->cdr).ivalue) { result.type = NIL; break; } cell = cell->cdr; } if (result.type != NIL) result.type = T; break; case LT: cell = cell->cdr; while (cell->cdr != NULL) { if (sgmt_eval(cell).ivalue >= sgmt_eval(cell->cdr).ivalue) { result.type = NIL; break; } cell = cell->cdr; } if (result.type != NIL) result.type = T; break; case GEQ: cell = cell->cdr; while (cell->cdr != NULL) { if (sgmt_eval(cell).ivalue < sgmt_eval(cell->cdr).ivalue) { result.type = NIL; break; } cell = cell->cdr; } if (result.type != NIL) result.type = T; break; case LEQ: cell = cell->cdr; while (cell->cdr != NULL) { if (sgmt_eval(cell).ivalue > sgmt_eval(cell->cdr).ivalue) { result.type = NIL; break; } cell = cell->cdr; } if (result.type != NIL) result.type = T; break; case EQ: cell = cell->cdr; while (cell->cdr != NULL) { if (sgmt_eval(cell).ivalue != sgmt_eval(cell->cdr).ivalue) { result.type = NIL; break; } cell = cell->cdr; } if (result.type != NIL) result.type = T; break; case SETQ: result = setq_eval(cell, result); break; case SYMBOL: result.ivalue = vtable[hash(cell->symbol)]->data; break; case DEFUN: result = defun_eval(cell, result); break; case END: break; } return result; }
int main(int argc, char *argv[]) { int n=get_num_ind(); int i,j; struct timeval tv1,tv2; adouble *xad; adouble fad; double f; double *x; x=new double[n]; xad=new adouble[n]; get_initial_value(x); printf("evaluating the function..."); trace_on(tag); for(i=0;i<n;i++) { xad[i] <<= x[i]; } fad=func_eval(xad); fad >>= f; trace_off(); printf("done!\n"); // printf("function value =<%10.20f>\n",f); // function(tag,1,n,x,&f); // printf("adolc func value=<%10.20f>\n",f); //tape_doc(tag,1,n,x,&f); #ifdef _compare_with_full double **H; H = myalloc2(n,n); printf("computing full hessain...."); gettimeofday(&tv1,NULL); hessian(tag,n,x,H); printf("done\n"); gettimeofday(&tv2,NULL); printf("Computing the full hessian cost %10.6f seconds\n",(tv2.tv_sec-tv1.tv_sec)+(double)(tv2.tv_usec-tv1.tv_usec)/1000000); #ifdef _PRINTOUT for(i=0;i<n;i++){ for(j=0;j<n;j++){ printf("H[%d][%d]=<%10.10f>",i,j,H[i][j]); } printf("\n"); } printf("\n"); #endif #endif #ifdef edge_pushing unsigned int *rind = NULL; unsigned int *cind = NULL; double *values = NULL; int nnz; int options[2]; options[0]=PRE_ACC; options[1]=COMPUT_GRAPH; gettimeofday(&tv1,NULL); // edge_hess(tag, 1, n, x, &nnz, &rind, &cind, &values, options); sparse_hess(tag,n,0,x, &nnz, &rind, &cind, &values, options); gettimeofday(&tv2,NULL); printf("Sparse Hessian: edge pushing cost %10.6f seconds\n",(tv2.tv_sec-tv1.tv_sec)+(double)(tv2.tv_usec-tv1.tv_usec)/1000000); #ifdef _PRINTOUT for(i=0;i<nnz;i++){ printf("<%d,%d>:<%10.10f>\n",cind[i],rind[i],values[i]); // printf("%d %d \n", rind[i], cind[i]); } #endif #endif #ifdef _compare_with_full #ifdef edge_pushing compare_matrix(n,H,nnz,cind,rind,values); #endif myfree2(H); #endif #ifdef edge_pushing printf("nnz=%d\n", nnz); free(rind); rind=NULL; free(cind); cind=NULL; free(values); values=NULL; #endif delete[] x; delete[] xad; return 0; }
int main(int argc, const char *argv[]) { char *eq[]={"{x-sin(3/2*(x+y)), y-cos(3/2*(x+y))}", "{x^3+y^2+1, x^2+y^2+2}", "{2*x^2+y, x+2*y+5}", "{3*x^2-1,log(x)+y+3}", //-eq 0 -eps 1e-100 --> ## 2 step 戻る ## 実数解 "{x^2+y^2+x^2-1,x^2+z^2-y,x-z}", //eq 5 ## 2step 戻る ## "{-x+x^2+2*y^2+2*z^2+2*w^2, -y+2*x*y+2*y*z+2*z*w, -z+y^2+2*x*z+2*y*w, -1+x+2*y+2*z+2*w}", //eq 6 ## 2step 戻る ## "{x-10000-y^2,x*y^2-100}", // eq 8 ## 2step 戻る ## "{0.3*x^2-1}", // eq 9 ## 2step 戻る ## "{(3*x-y^2)^3-1000,log(x)^(-1)+2*y-30}", //eq 12 ### 3step 戻る ### "{cos(0.5*x)+cos(y)-1, sin(0.5*x)-sin(y)-1}", //eq31 // x=pi, y=0 ## 2回 2step 戻る ## "{-x+x^2+2*y^2+2*z^2+2*w^2, -y+2*x*y+2*y*z+2*z*w, -z+y^2+2*x*z+2*y*w, -1+x+2*y+2*z+2*w}", //eq 36 4変数 x=1, y=z=w=0 ## 2step 戻る ## "{x^2-y^2-1,x^4-y^4-1999}", // 桁落ち kappa=0.06, 解 x=sqrt(1000),y=sqrt(999) "{x^2+y^2-1, x^2+2*x*y+y^2-2}", // 線形 "{x+y,x*y}", // 線形,零 NULL }; int debug=0,i,m,step_max0=-1,step_max=-1,prec0=53,prec=53,no=0,solve_true=0,info,seed=0,eterm=0,e_prec=2048,e_seed=-1,kappa=26,l=4; double mu=8; func_t *fF=NULL; cmulti **x0=NULL,**x=NULL,**x_true=NULL,**e=NULL; rmulti *eps=NULL,*eps_true=NULL; // init func_t func_eval(func_script("begin(x,y,z,w,v,u)")); // default prec set_default_prec(prec0); // allocate RA(eps); RA(eps_true); // default parameters rset_d(eps,1e-200); rset_s(eps_true,"1e-2000"); // get options i=1; while(i<argc){ if(STR_EQ(argv[i],"--help")) { usage(); } else if(STR_EQ(argv[i],"-v")) { debug=1; } else if(STR_EQ(argv[i],"-vv")) { debug=2; } else if(STR_EQ(argv[i],"-vvv")) { debug=3; } else if(STR_EQ(argv[i],"-true")) { solve_true=1; } else if(STR_EQ(argv[i],"-eterm")) { eterm=1; } else if(i+1<argc && STR_EQ(argv[i],"-mu")) { mu=atof(argv[++i]); } else if(i+1<argc && STR_EQ(argv[i],"-l")) { l=atoi(argv[++i]); } else if(i+1<argc && STR_EQ(argv[i],"-kappa")){ kappa=atoi(argv[++i]); } else if(i+1<argc && STR_EQ(argv[i],"-eq")) { no=atoi(argv[++i]); } else if(i+1<argc && STR_EQ(argv[i],"-n")) { step_max=atoi(argv[++i]); } else if(i+1<argc && STR_EQ(argv[i],"-prec0")){ prec0=atoi(argv[++i]); } else if(i+1<argc && STR_EQ(argv[i],"-prec")) { prec=atoi(argv[++i]); } else if(i+1<argc && STR_EQ(argv[i],"-e-prec")){ e_prec=atoi(argv[++i]); } else if(i+1<argc && STR_EQ(argv[i],"-e-seed")){ e_seed=atoi(argv[++i]); } else if(i+1<argc && STR_EQ(argv[i],"-eps")) { rset_s(eps,argv[++i]); } else if(i+1<argc && STR_EQ(argv[i],"-seed")) { seed=atoi(argv[++i]); } else { usage(); } i++; } // printf("step_max=%d\n",step_max); printf("mu=%g\n",mu); printf("l=%d\n",l); printf("kappa=%d\n",kappa); fF=func_script(eq[no]); printf("fF="); func_print(fF); printf("\n"); m=func_asize(fF); printf("m=%d\n",m); // allocate vectors and matrices set_default_prec(prec0); printf("prec0=%d\n",prec0); CVA(x0,m); CVA(x,m); CVA(x_true,m); CVA(e,m); // set initial vector init_genrand(seed); cvec_set_rand(m,x0,2,-1); cvec_print(m,x0,"x0=","f",6); // solve for true solution printf("#-------------------\n"); cvec_clone(m,x_true,x0); csolve_newton(m,x_true,fF,step_max0,debug); //prec=csolve_newton_adjust(m,x_true,fF,NULL,eps_true,step_max0,mu,l,kappa,debug); cvec_print(m,x_true,"x*=","e",20); cvec_clone(m,x,x_true); // solve if(solve_true){ printf("#-------------------\n"); cvec_clone(m,x,x0); prec=csolve_newton_adjust(m,x,fF,x_true,eps,step_max,mu,l,kappa,debug); cvec_print(m,x,"x=","e",20); } // error printf("#-------------------\n"); printf("prec=%d\n",prec); set_default_prec(prec); cvec_round(m,e,prec); cvec_set_nan(m,e); info=csolve_krawczyk(m,e,x,fF,debug-2); if(info){ print_red(); printf("failed.\n"); } else{ print_green(); printf("succeeded.\n"); } print_reset(); cvec_print(m,e,"e=","e",1); if(eterm){ printf("#-------------------\n"); if(e_seed>=0){ init_genrand(e_seed); cvec_set_rand(m,x,2,-1); } eterm_show(m,x,fF,e_prec,kappa); } // done printf("#-------------------\n"); fF=func_del(fF); func_clear(); RF(eps); CVF(x,m); CVF(e,m); printf("func_new_del_check_sum=%d\n",func_new_del_check_sum()); return 0; }