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

Last change on this file since 1052 was 986, checked in by gah, 16 years ago

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