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

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

Final tweaks on the optimization package. The demo now works properly.
Just run "wish simple.tcl" to see it work.

Fixed the Tool class to work better with the optimizer. The "run"
method now returns the result directly as a Rappture::Library object,
and the Analyzer merely loads the object.

File size: 29.3 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                    if (option == NULL) {
419                        /* no particular option value? then include type */
420                        if (Tcl_ListObjAppendElement(interp, rrval,
421                              Tcl_NewStringObj("number",-1)) != TCL_OK) {
422                            Tcl_DecrRefCount(rrval);
423                            Tcl_DecrRefCount(rval);
424                            return TCL_ERROR;
425                        }
426                    }
427                    break;
428                case RP_OPTIMPARAM_STRING:
429                    optSpecPtr = rpOptimStringOpts;
430                    if (option == NULL) {
431                        /* no particular option value? then include type */
432                        if (Tcl_ListObjAppendElement(interp, rrval,
433                              Tcl_NewStringObj("string",-1)) != TCL_OK) {
434                            Tcl_DecrRefCount(rrval);
435                            Tcl_DecrRefCount(rval);
436                            return TCL_ERROR;
437                        }
438                    }
439                    break;
440                default:
441                    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
442                        "internal error: unrecognized parameter type",
443                        " for \"", envPtr->paramList[n]->name,"\"",
444                        (char*)NULL);
445                    Tcl_DecrRefCount(rrval);
446                    Tcl_DecrRefCount(rval);
447                    return TCL_ERROR;
448                }
449
450                if (option == NULL) {
451                    /* no particular option value */
452                    for (j=0; optSpecPtr[j].optname; j++) {
453                        char *curOpt = optSpecPtr[j].optname;
454                        /* append -option name */
455                        if (Tcl_ListObjAppendElement(interp, rrval,
456                              Tcl_NewStringObj(curOpt,-1)) != TCL_OK) {
457                            Tcl_DecrRefCount(rrval);
458                            Tcl_DecrRefCount(rval);
459                            return TCL_ERROR;
460                        }
461                        /* append option value */
462                        if (RpTclOptionGet(interp, optSpecPtr,
463                            (ClientData)envPtr->paramList[n],
464                            optSpecPtr[j].optname) != TCL_OK) {
465                            Tcl_DecrRefCount(rrval);
466                            Tcl_DecrRefCount(rval);
467                            return TCL_ERROR;
468                        }
469                        if (Tcl_ListObjAppendElement(interp, rrval,
470                              Tcl_GetObjResult(interp)) != TCL_OK) {
471                            Tcl_DecrRefCount(rrval);
472                            Tcl_DecrRefCount(rval);
473                            return TCL_ERROR;
474                        }
475                    }
476                } else {
477                    if (RpTclOptionGet(interp, optSpecPtr,
478                        (ClientData)envPtr->paramList[n], option) != 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                if (Tcl_ListObjAppendElement(interp, rval, rrval) != TCL_OK) {
491                    Tcl_DecrRefCount(rrval);
492                    Tcl_DecrRefCount(rval);
493                    return TCL_ERROR;
494                }
495                Tcl_DecrRefCount(rrval);
496            }
497        }
498
499        if (nmatches == 1) {
500            /* only one result? then return it directly */
501            Tcl_ListObjIndex(interp, rval, 0, &rrval);
502            Tcl_SetObjResult(interp, rrval);
503        } else {
504            /* return a whole list */
505            Tcl_SetObjResult(interp, rval);
506        }
507        Tcl_DecrRefCount(rval);
508        return TCL_OK;
509    }
510
511    /*
512     * OPTION:  configure ?-option? ?value -option value ...?
513     */
514    else if (*option == 'c' && strcmp(option,"configure") == 0) {
515        optSpecPtr = envPtr->pluginDefn->optionSpec;
516        if (objc == 2) {
517            /* report all values: -option val -option val ... */
518
519            rval = Tcl_NewListObj(0,NULL);
520            Tcl_IncrRefCount(rval);
521
522            for (n=0; optSpecPtr[n].optname; n++) {
523                if (RpTclOptionGet(interp, optSpecPtr,
524                    (ClientData)envPtr->pluginData,
525                    optSpecPtr[n].optname) != TCL_OK) {
526                    Tcl_DecrRefCount(rval);
527                    return TCL_ERROR;
528                }
529                if (Tcl_ListObjAppendElement(interp, rval,
530                      Tcl_NewStringObj(optSpecPtr[n].optname,-1)) != TCL_OK) {
531                    Tcl_DecrRefCount(rval);
532                    return TCL_ERROR;
533                }
534                if (Tcl_ListObjAppendElement(interp, rval,
535                      Tcl_GetObjResult(interp)) != TCL_OK) {
536                    Tcl_DecrRefCount(rval);
537                    return TCL_ERROR;
538                }
539            }
540            Tcl_SetObjResult(interp, rval);
541            Tcl_DecrRefCount(rval);
542            return TCL_OK;
543        }
544        else if (objc == 3) {
545            /* report the value for just one option */
546            option = Tcl_GetStringFromObj(objv[2], (int*)NULL);
547            return RpTclOptionGet(interp, optSpecPtr,
548                (ClientData)envPtr->pluginData, option);
549        }
550        else {
551            return RpTclOptionsProcess(interp, objc-2, objv+2,
552                optSpecPtr, envPtr->pluginData);
553        }
554    }
555
556    /*
557     * OPTION:  perform ?-tool name? ?-fitness expr? ?-updatecommand name?
558     */
559    else if (*option == 'p' && strcmp(option,"perform") == 0) {
560        /* use this tool by default */
561        toolPtr = toolDataPtr->toolPtr;
562
563        /* no -fitness function by default */
564        fitnessExpr = NULL;
565
566        /* no -updatecommand by default */
567        updateCmdPtr = NULL;
568
569        n = 2;
570        while (n < objc) {
571            option = Tcl_GetStringFromObj(objv[n], (int*)NULL);
572            if (n+1 >= objc) {
573                Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
574                    "missing value for option \"", option, "\"",
575                    (char*)NULL);
576                return TCL_ERROR;
577            }
578            if (strcmp(option,"-tool") == 0) {
579                toolPtr = objv[n+1];
580                n += 2;
581            }
582            else if (strcmp(option,"-fitness") == 0) {
583                fitnessExpr = Tcl_GetStringFromObj(objv[n+1], (int*)NULL);
584                n += 2;
585            }
586            else if (strcmp(option,"-updatecommand") == 0) {
587                updateCmdPtr = objv[n+1];
588                n += 2;
589            }
590            else {
591                Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
592                    "bad option \"", option, "\": should be -fitness, -tool,"
593                    " -updatecommand", (char*)NULL);
594                return TCL_ERROR;
595            }
596        }
597
598        /*
599         * Must have a tool object and a fitness function at this point,
600         * or else we don't know what to optimize.
601         */
602        if (toolPtr == NULL) {
603            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
604                "tool being optimized not specified via -tool option",
605                (char*)NULL);
606            return TCL_ERROR;
607        }
608        if (fitnessExpr == NULL) {
609            Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
610                "missing -fitness function for optimization",
611                (char*)NULL);
612            return TCL_ERROR;
613        }
614
615        Tcl_IncrRefCount(toolPtr);
616        if (updateCmdPtr) {
617            Tcl_IncrRefCount(updateCmdPtr);
618            toolDataPtr->updateCmdPtr = updateCmdPtr;
619        }
620
621        /* call the main optimization routine here */
622        status = (*envPtr->pluginDefn->runProc)(envPtr,
623            RpOptimizerPerformInTcl, fitnessExpr);
624
625        Tcl_DecrRefCount(toolPtr);
626        if (updateCmdPtr) {
627            Tcl_DecrRefCount(updateCmdPtr);
628            toolDataPtr->updateCmdPtr = NULL;
629        }
630
631        switch (status) {
632        case RP_OPTIM_SUCCESS:
633            Tcl_SetResult(interp, "success", TCL_STATIC);
634            break;
635        case RP_OPTIM_FAILURE:
636            Tcl_SetResult(interp, "failure", TCL_STATIC);
637            break;
638        case RP_OPTIM_ABORTED:
639            Tcl_SetResult(interp, "aborted", TCL_STATIC);
640            break;
641        case RP_OPTIM_UNKNOWN:
642        default:
643            Tcl_SetResult(interp, "???", TCL_STATIC);
644            break;
645        }
646        return TCL_OK;
647    }
648
649    /*
650     * OPTION:  using
651     */
652    else if (*option == 'u' && strcmp(option,"using") == 0) {
653        if (objc > 2) {
654            Tcl_WrongNumArgs(interp, 1, objv, "using");
655            return TCL_ERROR;
656        }
657        Tcl_SetResult(interp, envPtr->pluginDefn->name, TCL_STATIC);
658
659        /* if the -tool was specified, then add it as a second element */
660        toolDataPtr = (RpOptimToolData*)envPtr->toolData;
661        if (toolDataPtr->toolPtr) {
662            Tcl_AppendElement(interp,
663                Tcl_GetStringFromObj(toolDataPtr->toolPtr, (int*)NULL));
664        }
665        return TCL_OK;
666    }
667
668    else {
669        Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
670            "bad option \"", option, "\": should be add, configure, "
671            "get, perform, using", (char*)NULL);
672        return TCL_ERROR;
673    }
674    return TCL_OK;
675}
676
677/*
678 * ------------------------------------------------------------------------
679 *  RpOptimizerPerformInTcl()
680 *
681 *  Invoked as a call-back within RpOptimPerform() to handle each
682 *  optimization run.  Launches a run of a Rappture-based tool using
683 *  the given values and computes the value for the fitness function.
684 *
685 *  Returns RP_OPTIM_SUCCESS if the run was successful, along with
686 *  the value in the fitness function in fitnessPtr.  If something
687 *  goes wrong with the run, it returns RP_OPTIM_FAILURE.
688 * ------------------------------------------------------------------------
689 */
690static RpOptimStatus
691RpOptimizerPerformInTcl(envPtr, values, numValues, fitnessPtr)
692    RpOptimEnv *envPtr;       /* optimization environment */
693    RpOptimParam *values;     /* incoming values for the simulation */
694    int numValues;            /* number of incoming values */
695    double *fitnessPtr;       /* returns: computed value of fitness func */
696{
697    RpOptimStatus result = RP_OPTIM_SUCCESS;
698    Tcl_Obj *xmlObj = NULL;
699    RpOptimToolData *toolDataPtr = (RpOptimToolData*)envPtr->toolData;
700    Tcl_Interp *interp = toolDataPtr->interp;
701
702    int n, status;
703#define MAXBUILTIN 10
704    int objc; Tcl_Obj **objv, *storage[MAXBUILTIN], *getcmd[3];
705    int rc; Tcl_Obj **rv;
706    Tcl_Obj *dataPtr;
707    Tcl_DString buffer;
708
709    /*
710     * Set up the arguments for a Tcl evaluation.
711     */
712    objc = 2*numValues + 2;  /* "tool run" + (name value)*numValues */
713    if (objc > MAXBUILTIN) {
714        objv = (Tcl_Obj**)malloc(objc*sizeof(Tcl_Obj));
715    } else {
716        objv = storage;
717    }
718    objv[0] = toolDataPtr->toolPtr;
719    objv[1] = Tcl_NewStringObj("run",-1); Tcl_IncrRefCount(objv[1]);
720    for (n=0; n < numValues; n++) {
721        objv[2*n+2] = Tcl_NewStringObj(values[n].name, -1);
722        Tcl_IncrRefCount(objv[2*n+2]);
723
724        switch (values[n].type) {
725        case RP_OPTIMPARAM_NUMBER:
726            objv[2*n+3] = Tcl_NewDoubleObj(values[n].value.dval);
727            Tcl_IncrRefCount(objv[2*n+3]);
728            break;
729        case RP_OPTIMPARAM_STRING:
730            objv[2*n+3] = Tcl_NewStringObj(values[n].value.sval.str,-1);
731            Tcl_IncrRefCount(objv[2*n+3]);
732            break;
733        default:
734            panic("bad parameter type in RpOptimizerPerformInTcl()");
735        }
736    }
737
738    /*
739     *  Invoke the tool and pick apart its results.
740     */
741    status = Tcl_EvalObjv(interp, objc, objv, TCL_EVAL_GLOBAL);
742
743    if (status != TCL_OK) {
744        result = RP_OPTIM_FAILURE;
745        fprintf(stderr, "== JOB FAILED: %s\n", Tcl_GetStringResult(interp));
746    } else {
747        dataPtr = Tcl_GetObjResult(interp);
748        /* hang on to this while we pick it apart into rv[] */
749        Tcl_IncrRefCount(dataPtr);
750
751        if (Tcl_ListObjGetElements(interp, dataPtr, &rc, &rv) != TCL_OK) {
752            result = RP_OPTIM_FAILURE;
753            fprintf(stderr, "== JOB FAILED: %s\n", Tcl_GetStringResult(interp));
754        } else if (rc != 2
755                    || Tcl_GetIntFromObj(interp, rv[0], &status) != TCL_OK) {
756            result = RP_OPTIM_FAILURE;
757            fprintf(stderr, "== JOB FAILED: malformed result: expected {status output}\n");
758        } else {
759            if (status != 0) {
760                result = RP_OPTIM_FAILURE;
761                fprintf(stderr, "== JOB FAILED with status code %d:\n%s\n",
762                    status, Tcl_GetStringFromObj(rv[1], (int*)NULL));
763            } else {
764                /*
765                 *  Get the output value from the tool output in the
766                 *  result we just parsed above:  {status xmlobj}
767                 *
768                 *  Eventually, we should write a whole parser to
769                 *  handle arbitrary fitness functions.  For now,
770                 *  just query a single output value by calling:
771                 *    xmlobj get fitnessExpr
772                 */
773                xmlObj = rv[1];
774                /* hang onto this for -updatecommand below */
775                Tcl_IncrRefCount(xmlObj);
776
777                getcmd[0] = xmlObj;
778                getcmd[1] = Tcl_NewStringObj("get",-1);
779                getcmd[2] = Tcl_NewStringObj(envPtr->fitnessExpr,-1);
780                for (n=0; n < 3; n++) {
781                    Tcl_IncrRefCount(getcmd[n]);
782                }
783
784                status = Tcl_EvalObjv(interp, 3, getcmd, TCL_EVAL_GLOBAL);
785
786                if (status != TCL_OK) {
787                    result = RP_OPTIM_FAILURE;
788                    fprintf(stderr, "== UNEXPECTED ERROR while extracting output value:%s\n", Tcl_GetStringResult(interp));
789                } else if (Tcl_GetDoubleFromObj(interp,
790                      Tcl_GetObjResult(interp), fitnessPtr) != TCL_OK) {
791                    result = RP_OPTIM_FAILURE;
792                    fprintf(stderr, "== ERROR while extracting output value:%s\n", Tcl_GetStringResult(interp));
793                }
794                for (n=0; n < 3; n++) {
795                    Tcl_DecrRefCount(getcmd[n]);
796                }
797            }
798        }
799        Tcl_DecrRefCount(dataPtr);
800    }
801
802    /*
803     * Clean up objects created for command invocation.
804     */
805    for (n=1; n < objc; n++) {
806        Tcl_DecrRefCount(objv[n]);
807    }
808    if (objv != storage) {
809        free(objv);
810    }
811
812    /*
813     * If there's the -updatecommand was specified, execute it here
814     * to bring the application up-to-date and see if the user wants
815     * to abort.
816     */
817    if (toolDataPtr->updateCmdPtr) {
818        Tcl_DStringInit(&buffer);
819        Tcl_DStringAppend(&buffer,
820            Tcl_GetStringFromObj(toolDataPtr->updateCmdPtr, (int*)NULL), -1);
821        Tcl_DStringAppendElement(&buffer,
822            (xmlObj != NULL) ? Tcl_GetStringFromObj(xmlObj, (int*)NULL): "");
823
824        status = Tcl_GlobalEval(toolDataPtr->interp,
825            Tcl_DStringValue(&buffer));
826
827        if (status == TCL_ERROR) {
828            Tcl_BackgroundError(toolDataPtr->interp);
829        }
830        else if (status == TCL_BREAK || status == TCL_RETURN) {
831            result = RP_OPTIM_ABORTED;
832        }
833        Tcl_DStringFree(&buffer);
834    }
835
836    if (xmlObj) {
837        Tcl_DecrRefCount(xmlObj);  /* done with this now */
838    }
839    return result;
840}
Note: See TracBrowser for help on using the repository browser.