source: trunk/optimizer/src/rp_optimizer_tcl.c @ 899

Last change on this file since 899 was 899, checked in by mmc, 15 years ago

Added a -fitness option to the "perform" operation. Right now, you can
specify just the name of an output quantity, and that quantity can be
minimized or maximized. In the future, there should be an expression
parser so you can enter any function of Rappture quantities.

Fixed up the example so that it runs the Rosenbrock function, which is
difficult to minimize. Added a visualize.tcl script, so you can visualize
the output from many different runXXXX.xml files.

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