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

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

Changes Made: Vanilla restart added, no modifications can be made to existing parameters in the middle of a run. Only mutation creates a new population on restart.
New configuration options added: MutationandCrossover? option. amount to be mutated made configurable. configration for (not)allowing duplicate strings added. app-qdot and simple modified to keep pace with these changes.

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