/* 'InitLibrary' sets up gvars, rnams, functions */ static Int InitLibrary ( StructInitInfo * module ) { Obj func1; Obj body1; /* Complete Copy/Fopy registration */ UpdateCopyFopyInfo(); /* global variables used in handlers */ G_IS__FUNCTION = GVarName( "IS_FUNCTION" ); G_ADD__LIST = GVarName( "ADD_LIST" ); G_Error = GVarName( "Error" ); G_IS__IDENTICAL__OBJ = GVarName( "IS_IDENTICAL_OBJ" ); G_AND__FLAGS = GVarName( "AND_FLAGS" ); G_HASH__FLAGS = GVarName( "HASH_FLAGS" ); G_WITH__HIDDEN__IMPS__FLAGS = GVarName( "WITH_HIDDEN_IMPS_FLAGS" ); G_IS__SUBSET__FLAGS = GVarName( "IS_SUBSET_FLAGS" ); G_TRUES__FLAGS = GVarName( "TRUES_FLAGS" ); G_FLAGS__FILTER = GVarName( "FLAGS_FILTER" ); G_WITH__HIDDEN__IMPS__FLAGS__COUNT = GVarName( "WITH_HIDDEN_IMPS_FLAGS_COUNT" ); G_WITH__HIDDEN__IMPS__FLAGS__CACHE__MISS = GVarName( "WITH_HIDDEN_IMPS_FLAGS_CACHE_MISS" ); G_WITH__HIDDEN__IMPS__FLAGS__CACHE__HIT = GVarName( "WITH_HIDDEN_IMPS_FLAGS_CACHE_HIT" ); G_IMPLICATIONS = GVarName( "IMPLICATIONS" ); G_WITH__IMPS__FLAGS__CACHE = GVarName( "WITH_IMPS_FLAGS_CACHE" ); G_WITH__IMPS__FLAGS__COUNT = GVarName( "WITH_IMPS_FLAGS_COUNT" ); G_WITH__IMPS__FLAGS__CACHE__HIT = GVarName( "WITH_IMPS_FLAGS_CACHE_HIT" ); G_WITH__IMPS__FLAGS__CACHE__MISS = GVarName( "WITH_IMPS_FLAGS_CACHE_MISS" ); G_CLEAR__IMP__CACHE = GVarName( "CLEAR_IMP_CACHE" ); G_BIND__GLOBAL = GVarName( "BIND_GLOBAL" ); G_UNBIND__GLOBAL = GVarName( "UNBIND_GLOBAL" ); G_RANK__FILTERS = GVarName( "RANK_FILTERS" ); G_RankFilter = GVarName( "RankFilter" ); G_RANK__FILTER = GVarName( "RANK_FILTER" ); G_RANK__FILTER__LIST__CURRENT = GVarName( "RANK_FILTER_LIST_CURRENT" ); G_RANK__FILTER__LIST = GVarName( "RANK_FILTER_LIST" ); G_RANK__FILTER__COUNT = GVarName( "RANK_FILTER_COUNT" ); /* record names used in handlers */ /* information for the functions */ C_NEW_STRING( DefaultName, 14, "local function" ); C_NEW_STRING( FileName, 21, "GAPROOT/lib/filter1.g" ); NameFunc[1] = DefaultName; NamsFunc[1] = 0; NargFunc[1] = 0; NameFunc[2] = DefaultName; NamsFunc[2] = 0; NargFunc[2] = 0; NameFunc[3] = DefaultName; NamsFunc[3] = 0; NargFunc[3] = 1; NameFunc[4] = DefaultName; NamsFunc[4] = 0; NargFunc[4] = 1; NameFunc[5] = DefaultName; NamsFunc[5] = 0; NargFunc[5] = 1; NameFunc[6] = DefaultName; NamsFunc[6] = 0; NargFunc[6] = 1; /* create all the functions defined in this module */ func1 = NewFunction(NameFunc[1],NargFunc[1],NamsFunc[1],HdlrFunc1); ENVI_FUNC( func1 ) = TLS(CurrLVars); CHANGED_BAG( TLS(CurrLVars) ); body1 = NewBag( T_BODY, NUMBER_HEADER_ITEMS_BODY*sizeof(Obj)); BODY_FUNC( func1 ) = body1; CHANGED_BAG( func1 ); CALL_0ARGS( func1 ); /* return success */ return 0; }
/* handler for function 6 */ static Obj HdlrFunc6 ( Obj self, Obj a_filter ) { Obj l_hash = 0; Obj l_flags = 0; Obj t_1 = 0; Obj t_2 = 0; Obj t_3 = 0; Obj t_4 = 0; Bag oldFrame; OLD_BRK_CURR_STAT /* allocate new stack frame */ SWITCH_TO_NEW_FRAME(self,0,0,oldFrame); REM_BRK_CURR_STAT(); SET_BRK_CURR_STAT(0); /* if IS_FUNCTION( filter ) then */ t_3 = GF_IS__FUNCTION; t_2 = CALL_1ARGS( t_3, a_filter ); CHECK_FUNC_RESULT( t_2 ) CHECK_BOOL( t_2 ) t_1 = (Obj)(UInt)(t_2 != False); if ( t_1 ) { /* flags := FLAGS_FILTER( filter ); */ t_2 = GF_FLAGS__FILTER; t_1 = CALL_1ARGS( t_2, a_filter ); CHECK_FUNC_RESULT( t_1 ) l_flags = t_1; } /* else */ else { /* flags := filter; */ l_flags = a_filter; } /* fi */ /* hash := HASH_FLAGS( flags ); */ t_2 = GF_HASH__FLAGS; t_1 = CALL_1ARGS( t_2, l_flags ); CHECK_FUNC_RESULT( t_1 ) l_hash = t_1; /* if hash <> RANK_FILTER_LIST[RANK_FILTER_COUNT] then */ t_3 = GC_RANK__FILTER__LIST; CHECK_BOUND( t_3, "RANK_FILTER_LIST" ) t_4 = GC_RANK__FILTER__COUNT; CHECK_BOUND( t_4, "RANK_FILTER_COUNT" ) CHECK_INT_POS( t_4 ) C_ELM_LIST_FPL( t_2, t_3, t_4 ) t_1 = (Obj)(UInt)( ! EQ( l_hash, t_2 )); if ( t_1 ) { /* Error( "corrupted completion file" ); */ t_1 = GF_Error; C_NEW_STRING( t_2, 25, "corrupted completion file" ); CALL_1ARGS( t_1, t_2 ); } /* fi */ /* RANK_FILTER_COUNT := RANK_FILTER_COUNT + 2; */ t_2 = GC_RANK__FILTER__COUNT; CHECK_BOUND( t_2, "RANK_FILTER_COUNT" ) C_SUM_FIA( t_1, t_2, INTOBJ_INT(2) ) AssGVar( G_RANK__FILTER__COUNT, t_1 ); /* return RANK_FILTER_LIST[RANK_FILTER_COUNT - 1]; */ t_2 = GC_RANK__FILTER__LIST; CHECK_BOUND( t_2, "RANK_FILTER_LIST" ) t_4 = GC_RANK__FILTER__COUNT; CHECK_BOUND( t_4, "RANK_FILTER_COUNT" ) C_DIFF_FIA( t_3, t_4, INTOBJ_INT(1) ) CHECK_INT_POS( t_3 ) C_ELM_LIST_FPL( t_1, t_2, t_3 ) RES_BRK_CURR_STAT(); SWITCH_TO_OLD_FRAME(oldFrame); return t_1; /* return; */ RES_BRK_CURR_STAT(); SWITCH_TO_OLD_FRAME(oldFrame); return 0; }
/* handler for function 1 */ static Obj HdlrFunc1 ( Obj self ) { Obj t_1 = 0; Obj t_2 = 0; Obj t_3 = 0; Obj t_4 = 0; Bag oldFrame; OLD_BRK_CURR_STAT /* allocate new stack frame */ SWITCH_TO_NEW_FRAME(self,0,0,oldFrame); REM_BRK_CURR_STAT(); SET_BRK_CURR_STAT(0); /* WITH_HIDDEN_IMPS_FLAGS_COUNT := 0; */ AssGVar( G_WITH__HIDDEN__IMPS__FLAGS__COUNT, INTOBJ_INT(0) ); /* WITH_HIDDEN_IMPS_FLAGS_CACHE_MISS := 0; */ AssGVar( G_WITH__HIDDEN__IMPS__FLAGS__CACHE__MISS, INTOBJ_INT(0) ); /* WITH_HIDDEN_IMPS_FLAGS_CACHE_HIT := 0; */ AssGVar( G_WITH__HIDDEN__IMPS__FLAGS__CACHE__HIT, INTOBJ_INT(0) ); /* IMPLICATIONS := [ ]; */ t_1 = NEW_PLIST( T_PLIST, 0 ); SET_LEN_PLIST( t_1, 0 ); AssGVar( G_IMPLICATIONS, t_1 ); /* WITH_IMPS_FLAGS_CACHE := [ ]; */ t_1 = NEW_PLIST( T_PLIST, 0 ); SET_LEN_PLIST( t_1, 0 ); AssGVar( G_WITH__IMPS__FLAGS__CACHE, t_1 ); /* WITH_IMPS_FLAGS_COUNT := 0; */ AssGVar( G_WITH__IMPS__FLAGS__COUNT, INTOBJ_INT(0) ); /* WITH_IMPS_FLAGS_CACHE_HIT := 0; */ AssGVar( G_WITH__IMPS__FLAGS__CACHE__HIT, INTOBJ_INT(0) ); /* WITH_IMPS_FLAGS_CACHE_MISS := 0; */ AssGVar( G_WITH__IMPS__FLAGS__CACHE__MISS, INTOBJ_INT(0) ); /* Unbind( CLEAR_IMP_CACHE ); */ AssGVar( G_CLEAR__IMP__CACHE, 0 ); /* BIND_GLOBAL( "CLEAR_IMP_CACHE", function ( ) WITH_IMPS_FLAGS_CACHE := [ ]; return; end ); */ t_1 = GF_BIND__GLOBAL; C_NEW_STRING( t_2, 15, "CLEAR_IMP_CACHE" ); t_3 = NewFunction( NameFunc[2], NargFunc[2], NamsFunc[2], HdlrFunc2 ); ENVI_FUNC( t_3 ) = TLS(CurrLVars); t_4 = NewBag( T_BODY, NUMBER_HEADER_ITEMS_BODY*sizeof(Obj) ); STARTLINE_BODY(t_4) = INTOBJ_INT(39); ENDLINE_BODY(t_4) = INTOBJ_INT(41); FILENAME_BODY(t_4) = FileName; BODY_FUNC(t_3) = t_4; CHANGED_BAG( TLS(CurrLVars) ); CALL_2ARGS( t_1, t_2, t_3 ); /* BIND_GLOBAL( "WITH_IMPS_FLAGS", function ( flags ) local with, changed, imp, hash, hash2, i; hash := HASH_FLAGS( flags ) mod 11001; for i in [ 0 .. 3 ] do hash2 := 2 * ((hash + 31 * i) mod 11001) + 1; if IsBound( WITH_IMPS_FLAGS_CACHE[hash2] ) then if IS_IDENTICAL_OBJ( WITH_IMPS_FLAGS_CACHE[hash2], flags ) then WITH_IMPS_FLAGS_CACHE_HIT := WITH_IMPS_FLAGS_CACHE_HIT + 1; return WITH_IMPS_FLAGS_CACHE[hash2 + 1]; fi; else break; fi; od; if i = 3 then WITH_IMPS_FLAGS_COUNT := (WITH_IMPS_FLAGS_COUNT + 1) mod 4; i := WITH_IMPS_FLAGS_COUNT; hash2 := 2 * ((hash + 31 * i) mod 11001) + 1; fi; WITH_IMPS_FLAGS_CACHE_MISS := WITH_IMPS_FLAGS_CACHE_MISS + 1; with := flags; changed := true; while changed do changed := false; for imp in IMPLICATIONS do if IS_SUBSET_FLAGS( with, imp[2] ) and not IS_SUBSET_FLAGS( with, imp[1] ) then with := AND_FLAGS( with, imp[1] ); changed := true; fi; od; od; WITH_IMPS_FLAGS_CACHE[hash2] := flags; WITH_IMPS_FLAGS_CACHE[hash2 + 1] := with; return with; end ); */ t_1 = GF_BIND__GLOBAL; C_NEW_STRING( t_2, 15, "WITH_IMPS_FLAGS" ); t_3 = NewFunction( NameFunc[3], NargFunc[3], NamsFunc[3], HdlrFunc3 ); ENVI_FUNC( t_3 ) = TLS(CurrLVars); t_4 = NewBag( T_BODY, NUMBER_HEADER_ITEMS_BODY*sizeof(Obj) ); STARTLINE_BODY(t_4) = INTOBJ_INT(44); ENDLINE_BODY(t_4) = INTOBJ_INT(83); FILENAME_BODY(t_4) = FileName; BODY_FUNC(t_3) = t_4; CHANGED_BAG( TLS(CurrLVars) ); CALL_2ARGS( t_1, t_2, t_3 ); /* UNBIND_GLOBAL( "RANK_FILTER" ); */ t_1 = GF_UNBIND__GLOBAL; C_NEW_STRING( t_2, 11, "RANK_FILTER" ); CALL_1ARGS( t_1, t_2 ); /* BIND_GLOBAL( "RANK_FILTER", function ( filter ) local rank, flags, i; rank := 0; if IS_FUNCTION( filter ) then flags := FLAGS_FILTER( filter ); else flags := filter; fi; for i in TRUES_FLAGS( WITH_HIDDEN_IMPS_FLAGS( flags ) ) do if IsBound( RANK_FILTERS[i] ) then rank := rank + RANK_FILTERS[i]; else rank := rank + 1; fi; od; return rank; end ); */ t_1 = GF_BIND__GLOBAL; C_NEW_STRING( t_2, 11, "RANK_FILTER" ); t_3 = NewFunction( NameFunc[4], NargFunc[4], NamsFunc[4], HdlrFunc4 ); ENVI_FUNC( t_3 ) = TLS(CurrLVars); t_4 = NewBag( T_BODY, NUMBER_HEADER_ITEMS_BODY*sizeof(Obj) ); STARTLINE_BODY(t_4) = INTOBJ_INT(97); ENDLINE_BODY(t_4) = INTOBJ_INT(114); FILENAME_BODY(t_4) = FileName; BODY_FUNC(t_3) = t_4; CHANGED_BAG( TLS(CurrLVars) ); CALL_2ARGS( t_1, t_2, t_3 ); /* RankFilter := RANK_FILTER; */ t_1 = GC_RANK__FILTER; CHECK_BOUND( t_1, "RANK_FILTER" ) AssGVar( G_RankFilter, t_1 ); /* UNBIND_GLOBAL( "RANK_FILTER_STORE" ); */ t_1 = GF_UNBIND__GLOBAL; C_NEW_STRING( t_2, 17, "RANK_FILTER_STORE" ); CALL_1ARGS( t_1, t_2 ); /* BIND_GLOBAL( "RANK_FILTER_STORE", function ( filter ) local hash, rank, flags; if IS_FUNCTION( filter ) then flags := FLAGS_FILTER( filter ); else flags := filter; fi; hash := HASH_FLAGS( flags ); rank := RANK_FILTER( flags ); ADD_LIST( RANK_FILTER_LIST_CURRENT, hash ); ADD_LIST( RANK_FILTER_LIST_CURRENT, rank ); return rank; end ); */ t_1 = GF_BIND__GLOBAL; C_NEW_STRING( t_2, 17, "RANK_FILTER_STORE" ); t_3 = NewFunction( NameFunc[5], NargFunc[5], NamsFunc[5], HdlrFunc5 ); ENVI_FUNC( t_3 ) = TLS(CurrLVars); t_4 = NewBag( T_BODY, NUMBER_HEADER_ITEMS_BODY*sizeof(Obj) ); STARTLINE_BODY(t_4) = INTOBJ_INT(119); ENDLINE_BODY(t_4) = INTOBJ_INT(133); FILENAME_BODY(t_4) = FileName; BODY_FUNC(t_3) = t_4; CHANGED_BAG( TLS(CurrLVars) ); CALL_2ARGS( t_1, t_2, t_3 ); /* UNBIND_GLOBAL( "RANK_FILTER_COMPLETION" ); */ t_1 = GF_UNBIND__GLOBAL; C_NEW_STRING( t_2, 22, "RANK_FILTER_COMPLETION" ); CALL_1ARGS( t_1, t_2 ); /* BIND_GLOBAL( "RANK_FILTER_COMPLETION", function ( filter ) local hash, flags; if IS_FUNCTION( filter ) then flags := FLAGS_FILTER( filter ); else flags := filter; fi; hash := HASH_FLAGS( flags ); if hash <> RANK_FILTER_LIST[RANK_FILTER_COUNT] then Error( "corrupted completion file" ); fi; RANK_FILTER_COUNT := RANK_FILTER_COUNT + 2; return RANK_FILTER_LIST[RANK_FILTER_COUNT - 1]; end ); */ t_1 = GF_BIND__GLOBAL; C_NEW_STRING( t_2, 22, "RANK_FILTER_COMPLETION" ); t_3 = NewFunction( NameFunc[6], NargFunc[6], NamsFunc[6], HdlrFunc6 ); ENVI_FUNC( t_3 ) = TLS(CurrLVars); t_4 = NewBag( T_BODY, NUMBER_HEADER_ITEMS_BODY*sizeof(Obj) ); STARTLINE_BODY(t_4) = INTOBJ_INT(136); ENDLINE_BODY(t_4) = INTOBJ_INT(151); FILENAME_BODY(t_4) = FileName; BODY_FUNC(t_3) = t_4; CHANGED_BAG( TLS(CurrLVars) ); CALL_2ARGS( t_1, t_2, t_3 ); /* return; */ RES_BRK_CURR_STAT(); SWITCH_TO_OLD_FRAME(oldFrame); return 0; /* return; */ RES_BRK_CURR_STAT(); SWITCH_TO_OLD_FRAME(oldFrame); return 0; }
static Obj FIND_BARYCENTER (Obj self, Obj gap_points, Obj gap_init, Obj gap_iter, Obj gap_tol) { #ifdef MALLOC_HACK old_malloc_hook = __malloc_hook; old_free_hook = __free_hook; __malloc_hook = my_malloc_hook; __free_hook = my_free_hook; #endif UInt i, j, n = LEN_PLIST(gap_points); Double __points[n][3]; bparams bparam = { n, __points }; for (i = 0; i < n; i++) for (j = 0; j < 3; j++) bparam.points[i][j] = VAL_FLOAT(ELM_PLIST(ELM_PLIST(gap_points,i+1),j+1)); const gsl_multiroot_fsolver_type *T; gsl_multiroot_fsolver *s; int status; size_t iter = 0, max_iter = INT_INTOBJ(gap_iter); double precision = VAL_FLOAT(gap_tol); gsl_multiroot_function f = {&barycenter, 3, &bparam}; gsl_vector *x = gsl_vector_alloc (3); for (i = 0; i < 3; i++) gsl_vector_set (x, i, VAL_FLOAT(ELM_PLIST(gap_init,i+1))); T = gsl_multiroot_fsolver_hybrids; s = gsl_multiroot_fsolver_alloc (T, 3); gsl_multiroot_fsolver_set (s, &f, x); do { iter++; status = gsl_multiroot_fsolver_iterate (s); if (status) /* check if solver is stuck */ break; status = gsl_multiroot_test_residual (s->f, precision); } while (status == GSL_CONTINUE && iter < max_iter); Obj result = ALLOC_PLIST(2); Obj list = ALLOC_PLIST(3); set_elm_plist(result, 1, list); for (i = 0; i < 3; i++) set_elm_plist(list, i+1, NEW_FLOAT(gsl_vector_get (s->x, i))); list = ALLOC_PLIST(3); set_elm_plist(result, 2, list); for (i = 0; i < 3; i++) set_elm_plist(list, i+1, NEW_FLOAT(gsl_vector_get (s->f, i))); gsl_multiroot_fsolver_free (s); gsl_vector_free (x); if (status != 0) { const char *s = gsl_strerror (status); C_NEW_STRING(result, strlen(s), s); } #ifdef MALLOC_HACK __malloc_hook = old_malloc_hook; __free_hook = old_free_hook; #endif return result; }