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

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

Added changes to accomodate gaussian profiles and random number distribution selection on a per gene basis.
also changed the mutation to a per gene based mutation if specified.

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