Context Navigation

source: trunk/packages/optimizer/src/rp_optimizer_tcl.c @ 1070

Last change on this file since 1070 was 1070, checked in by liveletlive, 16 years ago
Added changes to accomodate gaussian profiles and random number distribution selection on a per gene basis. also changed the mutation to a per gene based mutation if specified.
File size: 33.2 KB

Line
1	/*
2	* ----------------------------------------------------------------------
3	* rp_optimizer_tcl
4	*
5	* This is the Tcl API for the functions in rp_optimizer. This code
6	* allows you to call all of the core optimization functions from Tcl.
7	*
8	* ======================================================================
9	* AUTHOR: Michael McLennan, Purdue University
10	* Copyright (c) 2008 Purdue Research Foundation
11	*
12	* See the file "license.terms" for information on usage and
13	* redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
14	* ======================================================================
15	*/
16	#include "rp_optimizer.h"
17
18	extern int pgapack_abort;
19
20	/*
21	* ----------------------------------------------------------------------
22	* KNOWN OPTIMIZATION PACKAGES
23	* Add an entry below for each new optimization package that is
24	* plugged in and available via the -using option. End with all
25	* NULL values.
26	* ----------------------------------------------------------------------
27	*/
28	RpOptimInit PgapackInit;
29	RpOptimHandler PgapackRun;
30	RpOptimCleanup PgapackCleanup;
31	extern RpTclOption PgapackOptions;
32
33	static RpOptimPlugin rpOptimPlugins[] = {
34	{"pgapack", PgapackInit, PgapackRun, PgapackCleanup, &PgapackOptions},
35	{NULL, NULL, NULL},
36	};
37
38	typedef struct RpOptimToolData {
39	Tcl_Interp interp; / interp handling this tool */
40	Tcl_Obj toolPtr; / command for tool object */
41	Tcl_Obj updateCmdPtr; / command used to look for abort */
42	} RpOptimToolData;
43
44	/*
45	* ----------------------------------------------------------------------
46	* Options for the various parameter types
47	* ----------------------------------------------------------------------
48	*/
49
50	RpCustomTclOptionGet RpOption_GetRandDist;
51	RpCustomTclOptionParse RpOption_ParseRandDist;
52	RpTclOptionType RpOption_RandDist = {
53	"pga_randdist", RpOption_ParseRandDist,RpOption_GetRandDist,NULL
54	};
55	RpTclOption rpOptimNumberOpts[] = {
56	{"-min", RP_OPTION_DOUBLE, Rp_Offset(RpOptimParamNumber,min)},
57	{"-max", RP_OPTION_DOUBLE, Rp_Offset(RpOptimParamNumber,max)},
58	{"-mutnrate",RP_OPTION_DOUBLE, Rp_Offset(RpOptimParamNumber,mutnrate)},
59	{"-randdist",&RpOption_RandDist,Rp_Offset(RpOptimParamNumber,randdist)},
60	{"-strictmin",RP_OPTION_BOOLEAN,Rp_Offset(RpOptimParamNumber,strictmin)},
61	{"-strictmax",RP_OPTION_BOOLEAN,Rp_Offset(RpOptimParamNumber,strictmax)},
62	{"-stddev",RP_OPTION_DOUBLE,Rp_Offset(RpOptimParamNumber,stddev)},
63	{"-mean",RP_OPTION_DOUBLE,Rp_Offset(RpOptimParamNumber,mean)},
64	{NULL, NULL, 0}
65	};
66
67	RpTclOption rpOptimStringOpts[] = {
68	{"-values", RP_OPTION_LIST, Rp_Offset(RpOptimParamString,values)},
69	{NULL, NULL, 0}
70	};
71
72	static int RpOptimizerCmd _ANSI_ARGS_((ClientData clientData,
73	Tcl_Interp interp, int objc, Tcl_Obj CONST objv[]));
74	static void RpOptimCmdDelete _ANSI_ARGS_((ClientData cdata));
75	static int RpOptimInstanceCmd _ANSI_ARGS_((ClientData clientData,
76	Tcl_Interp interp, int objc, Tcl_Obj CONST objv[]));
77	static RpOptimStatus RpOptimizerPerformInTcl _ANSI_ARGS_((RpOptimEnv *envPtr,
78	RpOptimParam values, int numValues, double fitnessPtr));
79
80	#ifdef BUILD_Rappture
81	__declspec( dllexport )
82	#endif
83
84	extern int pgapack_abort;
85	extern void PGARuntimeDataTableInit();
86	extern void PGARuntimeDataTableDeInit();
87	extern void GetSampleInformation();
88
89	int
90	Rapptureoptimizer_Init(Tcl_Interp interp) / interpreter being initialized */
91	{
92	if (Tcl_InitStubs(interp, "8.4", 0) == NULL) {
93	return TCL_ERROR;
94	}
95	if (Tcl_PkgProvide(interp, "RapptureOptimizer", PACKAGE_VERSION)
96	!= TCL_OK) {
97	return TCL_ERROR;
98	}
99
100	Tcl_CreateObjCommand(interp, "::Rappture::optimizer", RpOptimizerCmd,
101	(ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);
102
103	return TCL_OK;
104	}
105
106	/*
107	* ------------------------------------------------------------------------
108	* RpOptimizerCmd()
109	*
110	* Invoked whenever someone uses the "optimizer" command to create a
111	* new optimizer context. Handles the following syntax:
112	*
113	* optimizer ?<name>? ?-using <pluginName>?
114	*
115	* Creates a command called <name> that can be used to manipulate
116	* the optimizer context. Returns TCL_OK on success, and TCL_ERROR
117	* (along with an error message in the interpreter) if anything goes
118	* wrong.
119	* ------------------------------------------------------------------------
120	*/
121	static int
122	RpOptimizerCmd(cdata, interp, objc, objv)
123	ClientData cdata; /* not used */
124	Tcl_Interp interp; / interpreter handling this request */
125	int objc; /* number of command line args */
126	Tcl_Obj CONST objv[]; / command line args */
127	{
128	/* use this for auto-generated names */
129	static int autocounter = 0;
130
131	/* use this plugin by default for -using */
132	RpOptimPlugin *usingPluginPtr = &rpOptimPlugins[0];
133
134	/* no good default for the tool being optimized */
135	Tcl_Obj *toolPtr = NULL;
136
137	/* no name for this object by default */
138	char *name = NULL;
139
140	RpOptimEnv* envPtr;
141	RpOptimPlugin* pluginPtr;
142	RpOptimToolData* toolDataPtr;
143
144	int n;
145	char option, autoname[32], sep;
146	Tcl_CmdInfo cmdInfo;
147
148	/*
149	* Make sure that a command with this name doesn't already exist.
150	*/
151	n = 1;
152	if (objc >= 2) {
153	name = Tcl_GetStringFromObj(objv[1], (int*)NULL);
154	if (*name != '-') {
155	if (Tcl_GetCommandInfo(interp, name, &cmdInfo)) {
156	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
157	"command \"", name, "\" already exists",
158	(char*)NULL);
159	return TCL_ERROR;
160	}
161	n++;
162	}
163	}
164
165	/*
166	* Parse the rest of the arguments.
167	*/
168	while (n < objc) {
169	option = Tcl_GetStringFromObj(objv[n], (int*)NULL);
170	if (strcmp(option,"-using") == 0) {
171	if (n+1 >= objc) {
172	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
173	"missing value for option \"", option, "\"",
174	(char*)NULL);
175	return TCL_ERROR;
176	}
177
178	/* search for a plugin with the given name */
179	option = Tcl_GetStringFromObj(objv[n+1], (int*)NULL);
180	for (pluginPtr=rpOptimPlugins; pluginPtr->name; pluginPtr++) {
181	if (strcmp(pluginPtr->name,option) == 0) {
182	break;
183	}
184	}
185	if (pluginPtr->name == NULL) {
186	/* oops! name not recognized */
187	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
188	"bad plugin name \"", option, "\": should be ",
189	(char*)NULL);
190
191	sep = "";
192	for (pluginPtr=rpOptimPlugins; pluginPtr->name; pluginPtr++) {
193	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
194	sep, pluginPtr->name, (char*)NULL);
195	sep = ", ";
196	}
197	return TCL_ERROR;
198	}
199	usingPluginPtr = pluginPtr;
200	n += 2;
201	}
202	else if (strcmp(option,"-tool") == 0) {
203	if (n+1 >= objc) {
204	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
205	"missing value for option \"", option, "\"",
206	(char*)NULL);
207	return TCL_ERROR;
208	}
209	toolPtr = objv[n+1];
210	Tcl_IncrRefCount(toolPtr);
211	n += 2;
212	}
213	else {
214	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
215	"bad option \"", option, "\": should be ",
216	"-tool, -using", (char*)NULL);
217	return TCL_ERROR;
218	}
219	}
220
221	/*
222	* If a name wasn't specified, then auto-generate one.
223	*/
224	while (name == NULL) {
225	sprintf(autoname, "optimizer%d", autocounter++);
226	if (!Tcl_GetCommandInfo(interp, autoname, &cmdInfo)) {
227	name = autoname;
228	}
229	}
230
231	/*
232	* Create an optimizer and install a Tcl command to access it.
233	*/
234	envPtr = RpOptimCreate(usingPluginPtr);
235
236	toolDataPtr = (RpOptimToolData*)malloc(sizeof(RpOptimToolData));
237	toolDataPtr->interp = interp;
238	toolDataPtr->toolPtr = toolPtr;
239	toolDataPtr->updateCmdPtr = NULL;
240	envPtr->toolData = (ClientData)toolDataPtr;
241	Tcl_CreateObjCommand(interp, name, RpOptimInstanceCmd,
242	(ClientData)envPtr, (Tcl_CmdDeleteProc*)RpOptimCmdDelete);
243	Tcl_SetResult(interp, name, TCL_VOLATILE);
244	return TCL_OK;
245	}
246
247	/*
248	* ----------------------------------------------------------------------
249	* RpOptimDelete()
250	*
251	* Called whenever a optimizer object is deleted to clean up after
252	* the command. If the optimizer is running, it is aborted, and
253	* the optimizer is deleted.
254	* ----------------------------------------------------------------------
255	*/
256	static void
257	RpOptimCmdDelete(cdata)
258	ClientData cdata; /* optimizer being deleted */
259	{
260	RpOptimEnv envPtr = (RpOptimEnv)cdata;
261	RpOptimToolData *toolDataPtr;
262	int n;
263	ClientData paramdata;
264
265	PGARuntimeDataTableDeInit();/Free space allocated to data table here/
266	if (envPtr->toolData) {
267	toolDataPtr = (RpOptimToolData*)envPtr->toolData;
268	if (toolDataPtr->toolPtr) {
269	Tcl_DecrRefCount(toolDataPtr->toolPtr);
270	}
271	if (toolDataPtr->updateCmdPtr) {
272	Tcl_DecrRefCount(toolDataPtr->updateCmdPtr);
273	}
274	free(toolDataPtr);
275	envPtr->toolData = NULL;
276	}
277
278	for (n=0; n < envPtr->numParams; n++) {
279	paramdata = (ClientData)envPtr->paramList[n];
280	switch (envPtr->paramList[n]->type) {
281	case RP_OPTIMPARAM_NUMBER:
282	RpTclOptionsCleanup(rpOptimNumberOpts, paramdata);
283	break;
284	case RP_OPTIMPARAM_STRING:
285	RpTclOptionsCleanup(rpOptimStringOpts, paramdata);
286	break;
287	}
288	}
289	RpOptimDelete(envPtr);
290	}
291
292	/*
293	* ------------------------------------------------------------------------
294	* RpOptimInstanceCmd()
295	*
296	* Invoked to handle the actions of an optimizer object. Handles the
297	* following syntax:
298	*
299	* <name> add number <path> ?-min <number>? ?-max <number>?
300	* <name> add string <path> ?-values <valueList>?
301	* <name> get ?<glob>? ?-option?
302	* <name> configure ?-option? ?value -option value ...?
303	* <name> perform ?-tool <tool>? ?-fitness <expr>? \
304	* ?-updatecommand <varName>?
305	* <name> using
306	* <name> samples ?number?
307	*
308	* The "add" command is used to add various parameter types to the
309	* optimizer context. The "perform" command kicks off an optimization
310	* run. The "samples" command displays sample info during an optimization run.
311	* ------------------------------------------------------------------------
312	*/
313	static int
314	RpOptimInstanceCmd(cdata, interp, objc, objv)
315	ClientData cdata; /* optimizer context */
316	Tcl_Interp interp; / interpreter handling this request */
317	int objc; /* number of command line args */
318	Tcl_Obj CONST objv[]; / command line args */
319	{
320	RpOptimEnv* envPtr = (RpOptimEnv*)cdata;
321	RpOptimToolData* toolDataPtr = (RpOptimToolData*)envPtr->toolData;
322
323	int n, j, nvals, nmatches;
324	char option, type, path, fitnessExpr;
325	RpOptimParam *paramPtr;
326	RpOptimParamString *strPtr;
327	RpOptimStatus status;
328	RpTclOption *optSpecPtr;
329	Tcl_Obj rval, rrval, toolPtr, updateCmdPtr;
330
331	if (objc < 2) {
332	Tcl_WrongNumArgs(interp, 1, objv, "option ?args...?");
333	return TCL_ERROR;
334	}
335	option = Tcl_GetStringFromObj(objv[1], (int*)NULL);
336
337	/*
338	* OPTION: add type ?args...?
339	*/
340	if (*option == 'a' && strcmp(option,"add") == 0) {
341	if (objc < 4) {
342	Tcl_WrongNumArgs(interp, 1, objv, "add type path ?args...?");
343	return TCL_ERROR;
344	}
345	type = Tcl_GetStringFromObj(objv[2], (int*)NULL);
346	path = Tcl_GetStringFromObj(objv[3], (int*)NULL);
347
348	/*
349	* OPTION: add number name ?-min num? ?-max num?
350	*/
351	if (*type == 'n' && strcmp(type,"number") == 0) {
352	paramPtr = RpOptimAddParamNumber(envPtr, path);
353	if (RpTclOptionsProcess(interp, objc-4, objv+4,
354	rpOptimNumberOpts, (ClientData)paramPtr) != TCL_OK) {
355	RpOptimDeleteParam(envPtr, path);
356	return TCL_ERROR;
357	}
358	}
359
360	/*
361	* OPTION: add string name ?-values list?
362	*/
363	else if (*type == 's' && strcmp(type,"string") == 0) {
364	paramPtr = RpOptimAddParamString(envPtr, path);
365	if (RpTclOptionsProcess(interp, objc-4, objv+4,
366	rpOptimStringOpts, (ClientData)paramPtr) != TCL_OK) {
367	RpOptimDeleteParam(envPtr, path);
368	return TCL_ERROR;
369	}
370
371	/* list of values just changed -- patch up the count */
372	strPtr = (RpOptimParamString*)paramPtr;
373	for (nvals=0; strPtr->values[nvals]; nvals++)
374	; /* count the values */
375	strPtr->numValues = nvals;
376	}
377	else {
378	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
379	"bad parameter type \"", type, "\": should be number, string",
380	(char*)NULL);
381	return TCL_ERROR;
382	}
383	} else if (*option == 'a' && strcmp(option,"abort") == 0) {
384	int value;
385
386	if (objc < 3) {
387	Tcl_WrongNumArgs(interp, 1, objv, "abort bool");
388	return TCL_ERROR;
389	}
390	if (Tcl_GetBooleanFromObj(interp, objv[2], &value) != TCL_OK) {
391	return TCL_ERROR;
392	}
393	pgapack_abort = value;
394	return TCL_OK;
395	} else if (*option == 'g' && strcmp(option,"get") == 0) {
396	/*
397	* OPTION: get ?globPattern? ?-option?
398	*/
399	if (objc > 2) {
400	path = Tcl_GetStringFromObj(objv[2], (int*)NULL);
401	} else {
402	path = NULL;
403	}
404	if (objc > 3) {
405	option = Tcl_GetStringFromObj(objv[3], (int*)NULL);
406	} else {
407	option = NULL;
408	}
409	if (objc > 4) {
410	Tcl_WrongNumArgs(interp, 1, objv, "get ?pattern? ?-option?");
411	return TCL_ERROR;
412	}
413
414	/* count the number of matches */
415	nmatches = 0;
416	for (n=0; n < envPtr->numParams; n++) {
417	if (path == NULL
418	\|\| Tcl_StringMatch(envPtr->paramList[n]->name,path)) {
419	nmatches++;
420	}
421	}
422
423	rval = Tcl_NewListObj(0,NULL);
424	Tcl_IncrRefCount(rval);
425	for (n=0; n < envPtr->numParams; n++) {
426	if (path == NULL
427	\|\| Tcl_StringMatch(envPtr->paramList[n]->name,path)) {
428
429	rrval = Tcl_NewListObj(0,NULL);
430	Tcl_IncrRefCount(rrval);
431
432	/* add the parameter name as the first element */
433	if (nmatches > 1 \|\| path == NULL) {
434	if (Tcl_ListObjAppendElement(interp, rrval,
435	Tcl_NewStringObj(envPtr->paramList[n]->name,-1))
436	!= TCL_OK) {
437	Tcl_DecrRefCount(rrval);
438	Tcl_DecrRefCount(rval);
439	return TCL_ERROR;
440	}
441	}
442
443	/* get the option specifications for this parameter */
444	switch (envPtr->paramList[n]->type) {
445	case RP_OPTIMPARAM_NUMBER:
446	optSpecPtr = rpOptimNumberOpts;
447	if (option == NULL) {
448	/* no particular option value? then include type */
449	if (Tcl_ListObjAppendElement(interp, rrval,
450	Tcl_NewStringObj("number",-1)) != TCL_OK) {
451	Tcl_DecrRefCount(rrval);
452	Tcl_DecrRefCount(rval);
453	return TCL_ERROR;
454	}
455	}
456	break;
457	case RP_OPTIMPARAM_STRING:
458	optSpecPtr = rpOptimStringOpts;
459	if (option == NULL) {
460	/* no particular option value? then include type */
461	if (Tcl_ListObjAppendElement(interp, rrval,
462	Tcl_NewStringObj("string",-1)) != TCL_OK) {
463	Tcl_DecrRefCount(rrval);
464	Tcl_DecrRefCount(rval);
465	return TCL_ERROR;
466	}
467	}
468	break;
469	default:
470	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
471	"internal error: unrecognized parameter type",
472	" for \"", envPtr->paramList[n]->name,"\"",
473	(char*)NULL);
474	Tcl_DecrRefCount(rrval);
475	Tcl_DecrRefCount(rval);
476	return TCL_ERROR;
477	}
478
479	if (option == NULL) {
480	/* no particular option value */
481	for (j=0; optSpecPtr[j].optname; j++) {
482	char *curOpt = optSpecPtr[j].optname;
483	/* append -option name */
484	if (Tcl_ListObjAppendElement(interp, rrval,
485	Tcl_NewStringObj(curOpt,-1)) != TCL_OK) {
486	Tcl_DecrRefCount(rrval);
487	Tcl_DecrRefCount(rval);
488	return TCL_ERROR;
489	}
490	/* append option value */
491	if (RpTclOptionGet(interp, optSpecPtr,
492	(ClientData)envPtr->paramList[n],
493	optSpecPtr[j].optname) != TCL_OK) {
494	Tcl_DecrRefCount(rrval);
495	Tcl_DecrRefCount(rval);
496	return TCL_ERROR;
497	}
498	if (Tcl_ListObjAppendElement(interp, rrval,
499	Tcl_GetObjResult(interp)) != TCL_OK) {
500	Tcl_DecrRefCount(rrval);
501	Tcl_DecrRefCount(rval);
502	return TCL_ERROR;
503	}
504	}
505	} else {
506	if (RpTclOptionGet(interp, optSpecPtr,
507	(ClientData)envPtr->paramList[n], option) != TCL_OK) {
508	Tcl_DecrRefCount(rrval);
509	Tcl_DecrRefCount(rval);
510	return TCL_ERROR;
511	}
512	if (Tcl_ListObjAppendElement(interp, rrval,
513	Tcl_GetObjResult(interp)) != TCL_OK) {
514	Tcl_DecrRefCount(rrval);
515	Tcl_DecrRefCount(rval);
516	return TCL_ERROR;
517	}
518	}
519	if (Tcl_ListObjAppendElement(interp, rval, rrval) != TCL_OK) {
520	Tcl_DecrRefCount(rrval);
521	Tcl_DecrRefCount(rval);
522	return TCL_ERROR;
523	}
524	Tcl_DecrRefCount(rrval);
525	}
526	}
527
528	if (nmatches == 1) {
529	/* only one result? then return it directly */
530	Tcl_ListObjIndex(interp, rval, 0, &rrval);
531	Tcl_SetObjResult(interp, rrval);
532	} else {
533	/* return a whole list */
534	Tcl_SetObjResult(interp, rval);
535	}
536	Tcl_DecrRefCount(rval);
537	return TCL_OK;
538	}
539
540	/*
541	* OPTION: configure ?-option? ?value -option value ...?
542	*/
543	else if (*option == 'c' && strcmp(option,"configure") == 0) {
544	optSpecPtr = envPtr->pluginDefn->optionSpec;
545	if (objc == 2) {
546	/* report all values: -option val -option val ... */
547
548	rval = Tcl_NewListObj(0,NULL);
549	Tcl_IncrRefCount(rval);
550
551	for (n=0; optSpecPtr[n].optname; n++) {
552	if (RpTclOptionGet(interp, optSpecPtr,
553	(ClientData)envPtr->pluginData,
554	optSpecPtr[n].optname) != TCL_OK) {
555	Tcl_DecrRefCount(rval);
556	return TCL_ERROR;
557	}
558	if (Tcl_ListObjAppendElement(interp, rval,
559	Tcl_NewStringObj(optSpecPtr[n].optname,-1)) != TCL_OK) {
560	Tcl_DecrRefCount(rval);
561	return TCL_ERROR;
562	}
563	if (Tcl_ListObjAppendElement(interp, rval,
564	Tcl_GetObjResult(interp)) != TCL_OK) {
565	Tcl_DecrRefCount(rval);
566	return TCL_ERROR;
567	}
568	}
569	Tcl_SetObjResult(interp, rval);
570	Tcl_DecrRefCount(rval);
571	return TCL_OK;
572	}
573	else if (objc == 3) {
574	/* report the value for just one option */
575	option = Tcl_GetStringFromObj(objv[2], (int*)NULL);
576	return RpTclOptionGet(interp, optSpecPtr,
577	(ClientData)envPtr->pluginData, option);
578	}
579	else {
580	return RpTclOptionsProcess(interp, objc-2, objv+2,
581	optSpecPtr, envPtr->pluginData);
582	}
583	}
584
585	/*
586	* OPTION: perform ?-tool name? ?-fitness expr? ?-updatecommand name?
587	*/
588	else if (*option == 'p' && strcmp(option,"perform") == 0) {
589	/* use this tool by default */
590	toolPtr = toolDataPtr->toolPtr;
591
592	/* no -fitness function by default */
593	fitnessExpr = NULL;
594
595	/* no -updatecommand by default */
596	updateCmdPtr = NULL;
597
598	PGARuntimeDataTableInit(envPtr);/Initialize Data table here..../
599
600	n = 2;
601	while (n < objc) {
602	option = Tcl_GetStringFromObj(objv[n], (int*)NULL);
603	if (n+1 >= objc) {
604	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
605	"missing value for option \"", option, "\"",
606	(char*)NULL);
607	return TCL_ERROR;
608	}
609	if (strcmp(option,"-tool") == 0) {
610	toolPtr = objv[n+1];
611	n += 2;
612	}
613	else if (strcmp(option,"-fitness") == 0) {
614	fitnessExpr = Tcl_GetStringFromObj(objv[n+1], (int*)NULL);
615	n += 2;
616	}
617	else if (strcmp(option,"-updatecommand") == 0) {
618	updateCmdPtr = objv[n+1];
619	n += 2;
620	}
621	else {
622	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
623	"bad option \"", option, "\": should be -fitness, -tool,"
624	" -updatecommand", (char*)NULL);
625	return TCL_ERROR;
626	}
627	}
628
629	/*
630	* Must have a tool object and a fitness function at this point,
631	* or else we don't know what to optimize.
632	*/
633	if (toolPtr == NULL) {
634	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
635	"tool being optimized not specified via -tool option",
636	(char*)NULL);
637	return TCL_ERROR;
638	}
639	if (fitnessExpr == NULL) {
640	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
641	"missing -fitness function for optimization",
642	(char*)NULL);
643	return TCL_ERROR;
644	}
645
646	Tcl_IncrRefCount(toolPtr);
647	if (updateCmdPtr) {
648	Tcl_IncrRefCount(updateCmdPtr);
649	toolDataPtr->updateCmdPtr = updateCmdPtr;
650	}
651
652	/* call the main optimization routine here */
653	status = (*envPtr->pluginDefn->runProc)(envPtr,
654	RpOptimizerPerformInTcl, fitnessExpr);
655
656	fprintf(stderr, ">>>status=%d\n", status);
657
658	Tcl_DecrRefCount(toolPtr);
659	if (updateCmdPtr) {
660	Tcl_DecrRefCount(updateCmdPtr);
661	toolDataPtr->updateCmdPtr = NULL;
662	}
663
664	switch (status) {
665	case RP_OPTIM_SUCCESS:
666	Tcl_SetResult(interp, "success", TCL_STATIC);
667	break;
668	case RP_OPTIM_FAILURE:
669	Tcl_SetResult(interp, "failure", TCL_STATIC);
670	break;
671	case RP_OPTIM_ABORTED:
672	fprintf(stderr, "Got abort status=%d\n", status);
673	Tcl_SetResult(interp, "aborted", TCL_STATIC);
674	break;
675	case RP_OPTIM_UNKNOWN:
676	default:
677	Tcl_SetResult(interp, "???", TCL_STATIC);
678	break;
679	}
680	return TCL_OK;
681	}
682
683	/*
684	* OPTION: using
685	*/
686	else if (*option == 'u' && strcmp(option,"using") == 0) {
687	if (objc > 2) {
688	Tcl_WrongNumArgs(interp, 1, objv, "using");
689	return TCL_ERROR;
690	}
691	Tcl_SetResult(interp, envPtr->pluginDefn->name, TCL_STATIC);
692
693	/* if the -tool was specified, then add it as a second element */
694	toolDataPtr = (RpOptimToolData*)envPtr->toolData;
695	if (toolDataPtr->toolPtr) {
696	Tcl_AppendElement(interp,
697	Tcl_GetStringFromObj(toolDataPtr->toolPtr, (int*)NULL));
698	}
699	return TCL_OK;
700	}
701
702	else if(*option == 's' && strcmp(option,"samples") == 0){
703	int sampleNumber = -1; /initing sampnum to -1, use it when no sample number is specified/
704	char *sampleDataBuffer;
705	if(objc>3){
706	Tcl_WrongNumArgs(interp, 2, objv, "?sampleNumber?");
707	return TCL_ERROR;
708	}
709
710	if(objc == 3){
711	if(Tcl_GetIntFromObj(interp,objv[2],&sampleNumber) != TCL_OK){
712	return TCL_ERROR;
713	}
714	sampleDataBuffer = malloc(sizeof(char)*SINGLE_SAMPLE_DATA_BUFFER_DEFAULT_SIZE);
715	}else{
716	sampleDataBuffer = malloc(sizeof(char)*50);
717	}
718
719	if(sampleDataBuffer == NULL){
720	panic("Error: Could not allocate memory for sample data buffer.");
721	}
722	GetSampleInformation(sampleDataBuffer,sampleNumber);
723	fprintf(stdout,sampleDataBuffer);/*TODO GTG check if this should be fprintf or something else/
724	free(sampleDataBuffer);
725	return TCL_OK;
726
727	}
728
729	else {
730	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
731	"bad option \"", option, "\": should be add, configure, "
732	"get, perform, using, samples", (char*)NULL);
733	return TCL_ERROR;
734	}
735	return TCL_OK;
736	}
737
738	/*
739	* ------------------------------------------------------------------------
740	* RpOptimizerPerformInTcl()
741	*
742	* Invoked as a call-back within RpOptimPerform() to handle each
743	* optimization run. Launches a run of a Rappture-based tool using
744	* the given values and computes the value for the fitness function.
745	*
746	* Returns RP_OPTIM_SUCCESS if the run was successful, along with
747	* the value in the fitness function in fitnessPtr. If something
748	* goes wrong with the run, it returns RP_OPTIM_FAILURE.
749	* ------------------------------------------------------------------------
750	*/
751	static RpOptimStatus
752	RpOptimizerPerformInTcl(envPtr, values, numValues, fitnessPtr)
753	RpOptimEnv envPtr; / optimization environment */
754	RpOptimParam values; / incoming values for the simulation */
755	int numValues; /* number of incoming values */
756	double fitnessPtr; / returns: computed value of fitness func */
757	{
758	RpOptimStatus result = RP_OPTIM_SUCCESS;
759	Tcl_Obj *xmlObj = NULL;
760	RpOptimToolData toolDataPtr = (RpOptimToolData)envPtr->toolData;
761	Tcl_Interp *interp = toolDataPtr->interp;
762
763	int n, status;
764	#define MAXBUILTIN 10
765	int objc; Tcl_Obj *objv, storage[MAXBUILTIN], *getcmd[3];
766	int rc; Tcl_Obj **rv;
767	Tcl_Obj *dataPtr;
768	Tcl_DString buffer;
769
770	/*
771	* Set up the arguments for a Tcl evaluation.
772	*/
773	objc = 2numValues + 2; / "tool run" + (name value)numValues /
774	if (objc > MAXBUILTIN) {
775	objv = (Tcl_Obj*)malloc(objcsizeof(Tcl_Obj));
776	} else {
777	objv = storage;
778	}
779	objv[0] = toolDataPtr->toolPtr;
780	objv[1] = Tcl_NewStringObj("run",-1); Tcl_IncrRefCount(objv[1]);
781	for (n=0; n < numValues; n++) {
782	objv[2*n+2] = Tcl_NewStringObj(values[n].name, -1);
783	Tcl_IncrRefCount(objv[2*n+2]);
784
785	switch (values[n].type) {
786	case RP_OPTIMPARAM_NUMBER:
787	objv[2*n+3] = Tcl_NewDoubleObj(values[n].value.dval);
788	Tcl_IncrRefCount(objv[2*n+3]);
789	break;
790	case RP_OPTIMPARAM_STRING:
791	objv[2*n+3] = Tcl_NewStringObj(values[n].value.sval.str,-1);
792	Tcl_IncrRefCount(objv[2*n+3]);
793	break;
794	default:
795	panic("bad parameter type in RpOptimizerPerformInTcl()");
796	}
797	}
798
799	/*
800	* Invoke the tool and pick apart its results.
801	*/
802	status = Tcl_EvalObjv(interp, objc, objv, TCL_EVAL_GLOBAL);
803
804	if (status != TCL_OK) {
805	result = RP_OPTIM_FAILURE;
806	fprintf(stderr, "== JOB FAILED: %s\n", Tcl_GetStringResult(interp));
807	} else {
808	dataPtr = Tcl_GetObjResult(interp);
809	/* hang on to this while we pick it apart into rv[] */
810	Tcl_IncrRefCount(dataPtr);
811
812	if (Tcl_ListObjGetElements(interp, dataPtr, &rc, &rv) != TCL_OK) {
813	result = RP_OPTIM_FAILURE;
814	fprintf(stderr, "== JOB FAILED: %s\n", Tcl_GetStringResult(interp));
815	} else if (rc != 2
816	\|\| Tcl_GetIntFromObj(interp, rv[0], &status) != TCL_OK) {
817	result = RP_OPTIM_FAILURE;
818	fprintf(stderr, "== JOB FAILED: malformed result: expected {status output}\n");
819	} else {
820	if (status != 0) {
821	result = RP_OPTIM_FAILURE;
822	fprintf(stderr, "== JOB FAILED with status code %d:\n%s\n",
823	status, Tcl_GetStringFromObj(rv[1], (int*)NULL));
824	} else {
825	/*
826	* Get the output value from the tool output in the
827	* result we just parsed above: {status xmlobj}
828	*
829	* Eventually, we should write a whole parser to
830	* handle arbitrary fitness functions. For now,
831	* just query a single output value by calling:
832	* xmlobj get fitnessExpr
833	*/
834	xmlObj = rv[1];
835	/* hang onto this for -updatecommand below */
836	Tcl_IncrRefCount(xmlObj);
837
838	getcmd[0] = xmlObj;
839	getcmd[1] = Tcl_NewStringObj("get",-1);
840	getcmd[2] = Tcl_NewStringObj(envPtr->fitnessExpr,-1);
841	for (n=0; n < 3; n++) {
842	Tcl_IncrRefCount(getcmd[n]);
843	}
844
845	status = Tcl_EvalObjv(interp, 3, getcmd, TCL_EVAL_GLOBAL);
846
847	if (status != TCL_OK) {
848	result = RP_OPTIM_FAILURE;
849	fprintf(stderr, "== UNEXPECTED ERROR while extracting output value:%s\n", Tcl_GetStringResult(interp));
850	} else if (Tcl_GetDoubleFromObj(interp,
851	Tcl_GetObjResult(interp), fitnessPtr) != TCL_OK) {
852	result = RP_OPTIM_FAILURE;
853	fprintf(stderr, "== ERROR while extracting output value:%s\n", Tcl_GetStringResult(interp));
854	}
855	for (n=0; n < 3; n++) {
856	Tcl_DecrRefCount(getcmd[n]);
857	}
858	}
859	}
860	Tcl_DecrRefCount(dataPtr);
861	}
862
863	/*
864	* Clean up objects created for command invocation.
865	*/
866	for (n=1; n < objc; n++) {
867	Tcl_DecrRefCount(objv[n]);
868	}
869	if (objv != storage) {
870	free(objv);
871	}
872
873	/*
874	* If there's the -updatecommand was specified, execute it here
875	* to bring the application up-to-date and see if the user wants
876	* to abort.
877	*/
878	if (toolDataPtr->updateCmdPtr) {
879	Tcl_DStringInit(&buffer);
880	Tcl_DStringAppend(&buffer,
881	Tcl_GetStringFromObj(toolDataPtr->updateCmdPtr, (int*)NULL), -1);
882	Tcl_DStringAppendElement(&buffer,
883	(xmlObj != NULL) ? Tcl_GetStringFromObj(xmlObj, (int*)NULL): "");
884
885	status = Tcl_GlobalEval(toolDataPtr->interp,
886	Tcl_DStringValue(&buffer));
887	if (status == TCL_ERROR) {
888	Tcl_BackgroundError(toolDataPtr->interp);
889	}
890	Tcl_DStringFree(&buffer);
891	}
892
893	if (xmlObj) {
894	Tcl_DecrRefCount(xmlObj); /* done with this now */
895	}
896	return result;
897	}
898
899	/*
900	* ======================================================================
901	* OPTION: -randdist <=> RAND_NUMBER_DIST_GAUSSIAN / RAND_NUMBER_DIST_UNIFORM
902	* ======================================================================
903	*/
904	int
905	RpOption_ParseRandDist(interp, valObj, cdata, offset)
906	Tcl_Interp interp; / interpreter handling this request */
907	Tcl_Obj valObj; / set option to this new value */
908	ClientData cdata; /* save in this data structure */
909	int offset; /* save at this offset in cdata */
910	{
911	int ptr = (int)(cdata+offset);
912	char val = Tcl_GetStringFromObj(valObj, (int)NULL);
913	if (strcmp(val,"gaussian") == 0) {
914	*ptr = RAND_NUMBER_DIST_GAUSSIAN;
915	}
916	else if (strcmp(val,"uniform") == 0) {
917	*ptr = RAND_NUMBER_DIST_UNIFORM;
918	}
919	else {
920	Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
921	"bad value \"", val, "\": should be gaussian or uniform",
922	(char*)NULL);
923	return TCL_ERROR;
924	}
925	return TCL_OK;
926	}
927
928	int
929	RpOption_GetRandDist(interp, cdata, offset)
930	Tcl_Interp interp; / interpreter handling this request */
931	ClientData cdata; /* get from this data structure */
932	int offset; /* get from this offset in cdata */
933	{
934	int ptr = (int)(cdata+offset);
935	switch (*ptr) {
936	case RAND_NUMBER_DIST_GAUSSIAN:
937	Tcl_SetResult(interp, "gaussian", TCL_STATIC);
938	break;
939	case RAND_NUMBER_DIST_UNIFORM:
940	Tcl_SetResult(interp, "uniform", TCL_STATIC);
941	break;
942	default:
943	Tcl_SetResult(interp, "???", TCL_STATIC);
944	break;
945	}
946	return TCL_OK;
947	}

Note: See TracBrowser for help on using the repository browser.

Download in other formats: