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

Last change on this file since 1154 was 1154, checked in by liveletlive, 14 years ago

tweaked the configuration code for number parameters.
added code required to include units of a number parameter.

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