C++ Tcl_GetDoubleFromObj函数代码示例

SEXP RTcl_ObjAsDoubleVector(SEXP args)
{
    int count;
    Tcl_Obj **elem, *obj;
    int ret, i;
    double x;
    SEXP ans;

    obj = (Tcl_Obj *) R_ExternalPtrAddr(CADR(args));
    if (!obj) error(_("invalid tclObj -- perhaps saved from another session?"));

    /* First try for single value */
    ret = Tcl_GetDoubleFromObj(RTcl_interp, obj, &x);
    if (ret == TCL_OK) return ScalarReal(x);

    /* Then try as list */
    ret = Tcl_ListObjGetElements(RTcl_interp, obj, &count, &elem);
    if (ret != TCL_OK) /* didn't work, return NULL */
	return R_NilValue;

    ans = allocVector(REALSXP, count);
    for (i = 0 ; i < count ; i++){
	ret = Tcl_GetDoubleFromObj(RTcl_interp, elem[i], &x);
	if (ret != TCL_OK) x = NA_REAL;
	REAL(ans)[i] = x;
    }
    return ans;
}

/* void draw_text_f (ESContext *esContext, float x1, float y1, float w, float h, char *file, char *text) { */
int tclcmd_draw_text_f (ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
    int len = 0;
    if (objc != 7) {
        Tcl_WrongNumArgs (interp, 1, objv, "{ESContext *esContext} { float x1} { float y1} { float w} { float h} { char *file} { char *text}");
        return TCL_ERROR;
    }
    double arg_x1;
    if (Tcl_GetDoubleFromObj(interp, objv[1], (double *)&arg_x1) != TCL_OK) {
        return TCL_ERROR;
    }
    double arg_y1;
    if (Tcl_GetDoubleFromObj(interp, objv[2], (double *)&arg_y1) != TCL_OK) {
        return TCL_ERROR;
    }
    double arg_w;
    if (Tcl_GetDoubleFromObj(interp, objv[3], (double *)&arg_w) != TCL_OK) {
        return TCL_ERROR;
    }
    double arg_h;
    if (Tcl_GetDoubleFromObj(interp, objv[4], (double *)&arg_h) != TCL_OK) {
        return TCL_ERROR;
    }
    char arg_file[1024];
    strncpy(arg_file, Tcl_GetStringFromObj(objv[5], &len), 1024);
    char arg_text[1024];
    strncpy(arg_text, Tcl_GetStringFromObj(objv[6], &len), 1024);
    draw_text_f(GlobalesContext, (float)arg_x1, (float)arg_y1, (float)arg_w, (float)arg_h, arg_file, arg_text);
    return TCL_OK;
}

static int
rotate(ClientData clientData, Tcl_Interp *interp, int objc,
        Tcl_Obj *const *objv)
{
    WHIRLYGIZMO *Wg;
    Togl   *togl;

    if (objc != 4) {
        Tcl_WrongNumArgs(interp, 1, objv, "pathName yrot xrot");
        return TCL_ERROR;
    }

    if (Togl_GetToglFromObj(interp, objv[1], &togl) != TCL_OK) {
        return TCL_ERROR;
    }

    Wg = (WHIRLYGIZMO *) Togl_GetClientData(togl);

    if (Tcl_GetDoubleFromObj(interp, objv[2], &Wg->Roty) != TCL_OK) {
        return TCL_ERROR;
    }
    if (Tcl_GetDoubleFromObj(interp, objv[3], &Wg->Rotx) != TCL_OK) {
        return TCL_ERROR;
    }
    Togl_PostRedisplay(togl);

    return TCL_OK;
}

int NLEnergy_add_bondprm(NLEnergy *p, Tcl_Interp *interp,
    int objc, Tcl_Obj *const objv[]) {
  ForcePrm *fprm = &(p->fprm);
  BondPrm a;
  const char *t = NULL;
  int n;
  double d;
  Tcl_Obj **aobjv;
  int aobjc;
  int32 id;

  TEXT("bondprm");
  if (objc != 3) return ERROR(ERR_EXPECT);
  t = Tcl_GetStringFromObj(objv[0], &n);
  if (n >= sizeof(AtomType) || 0==t[0]) return ERROR(ERR_EXPECT);
  strcpy(a.atomType[0], t);
  t = Tcl_GetStringFromObj(objv[1], &n);
  if (n >= sizeof(AtomType) || 0==t[0]) return ERROR(ERR_EXPECT);
  strcpy(a.atomType[1], t);
  if (TCL_ERROR==Tcl_ListObjGetElements(interp, objv[2], &aobjc, &aobjv)
      || aobjc != 2) return ERROR(ERR_EXPECT);
  if (TCL_ERROR==Tcl_GetDoubleFromObj(interp, aobjv[0], &d)
      || d < 0) return ERROR(ERR_EXPECT);
  a.k = d * ENERGY_INTERNAL;
  if (TCL_ERROR==Tcl_GetDoubleFromObj(interp, aobjv[1], &d)
      || d < 0) return ERROR(ERR_EXPECT);
  a.r0 = d;
  if ((id=ForcePrm_add_bondprm(fprm, &a)) < OK) {
    return (id < FAIL ? ERROR(id) : FAIL);
  }
  if ((n=Topology_setprm_bond_array(&(p->topo))) < FAIL) return ERROR(n);
  return OK;
}

static int findItemAt( Tcl_Interp *interp,
      int objc, Tcl_Obj * const objv[], CanvasParams *params )
{
   double   x, y;
   GnomeCanvasItem *item;
   Gnocl_CanvasItemInfo *info;

   if( objc != 4 )
   {
      Tcl_WrongNumArgs( interp, 2, objv, /* canvas findItemAt */ "x y" );
      return TCL_ERROR;
   }

   if( Tcl_GetDoubleFromObj( interp, objv[2], &x ) != TCL_OK )
      return TCL_ERROR;
   if( Tcl_GetDoubleFromObj( interp, objv[3], &y ) != TCL_OK )
      return TCL_ERROR;
   
   item = gnome_canvas_get_item_at( params->canvas, x, y );
   /* printf( "item: %p %f %f\n", item, x, y ); */
   info = gnoclInfoFromCanvasItem( params, item );
   if( info )
      Tcl_SetObjResult( interp, Tcl_NewIntObj( info->id ) );

   return TCL_OK;
}

int tcl_pmepot_add(ClientData nodata, Tcl_Interp *interp,
			int objc, Tcl_Obj *const objv[]) {

  int cell_count, atom_count, sub_count, i, j;
  Tcl_Obj **cell_list, **atom_list, **sub_list;
  float cell[12], *atoms;
  double d;
  pmepot_data *data;
  if ( objc != 4 ) {
    Tcl_SetResult(interp,"args: handle {{o...} {a...} {b...} {c...}} {{x y z q}...}",TCL_VOLATILE);
    return TCL_ERROR;
  }
  data = Tcl_GetAssocData(interp, Tcl_GetString(objv[1]), 0);
  if ( ! data ) {
    Tcl_SetResult(interp,"Pmepot bug: unable to access handle.",TCL_VOLATILE);
    return TCL_ERROR;
  }

  if ( Tcl_ListObjGetElements(interp,objv[2],&cell_count,&cell_list) != TCL_OK ) return TCL_ERROR;
  if ( cell_count != 4 ) {
    Tcl_SetResult(interp,"cell format: {{ox oy oz} {ax ay az} {bx by bz} {cx cy cz}}",TCL_VOLATILE);
    return TCL_ERROR;
  }
  for ( i=0; i<4; ++i ) {
    if ( Tcl_ListObjGetElements(interp,cell_list[i],&sub_count,&sub_list) != TCL_OK ) return TCL_ERROR;
    if ( sub_count != 3 ) {
      Tcl_SetResult(interp,"cell format: {{ox oy oz} {ax ay az} {bx by bz} {cx cy cz}}",TCL_VOLATILE);
      return TCL_ERROR;
    }
    for ( j=0; j<3; ++j ) {
      if ( Tcl_GetDoubleFromObj(interp,sub_list[j],&d) != TCL_OK ) return TCL_ERROR;
      cell[3*i+j] = d;
    }
  }
  if ( Tcl_ListObjGetElements(interp,objv[3],&atom_count,&atom_list) != TCL_OK ) return TCL_ERROR;
  atoms = malloc(atom_count*4*sizeof(float));
  for ( i=0; i<atom_count; ++i ) {
    if ( Tcl_ListObjGetElements(interp,atom_list[i],&sub_count,&sub_list) != TCL_OK ) { free(atoms); return TCL_ERROR; }
    if ( sub_count != 4 ) {
      Tcl_SetResult(interp,"atoms format: {{x y z q}...}",TCL_VOLATILE);
      free(atoms); return TCL_ERROR;
    }
    for ( j=0; j<4; ++j ) {
      if ( Tcl_GetDoubleFromObj(interp,sub_list[j],&d) != TCL_OK ) { free(atoms); return TCL_ERROR; }
      atoms[4*i+j] = d;
    }
  }

  if ( pmepot_add(data,cell,atom_count,atoms) ) {
    Tcl_SetResult(interp,"Pmepot bug: pmepot_add failed.",TCL_VOLATILE);
    free(atoms);
    return TCL_ERROR;
  }

  free(atoms);
  return TCL_OK;
}

/****
 * implementation of Tcl shape_create routine 
 ****/
int tclShapeCreate(ClientData data,Tcl_Interp* interp,int argc, char *argv[])
{
   int slot, i, j, k, len, shft;
   char expr[2048];
   double a, p;
   Tcl_Obj *tclres;

  if ( (argc < 2) || (argc > 6) )
    return TclError(interp,"usage: shape_create <num of lems> | -ampl <ampl expr> | -phase <phase expr>");
  if (Tcl_GetInt(interp,argv[1],&len) == TCL_ERROR)
    return TclError(interp,"shape_create: argument 1 must be integer <num of elems>");

  /* get a new slot and allocate */
  slot = RFshapes_slot();
  if (slot == -1) {
     return TclError(interp,"shape_create error: no more free slots available, free some shape first!");
  }
  RFshapes[slot] = RFshapes_alloc(len);

  for (i=1; i<=len; i++) {
     RFshapes[slot][i].ampl = 0.0;
     RFshapes[slot][i].phase = 0.0;
  }

  for (i=2; i<argc; i++) {
     if (!strcmp(argv[i],"-ampl")) {
        i++;
        /* evaluate expression in Tcl */
        for (j=1; j<=len; j++) {
           sprintf(expr,"\n set i %d\n expr %s\n", j, argv[i]);
           if ( Tcl_EvalEx(interp, expr, -1,TCL_EVAL_DIRECT) != TCL_OK ) 
              return TclError(interp,"error in shape_create: can not evaluate %s for index %d",argv[i], j);
           tclres = Tcl_GetObjResult(interp);
           if ( Tcl_GetDoubleFromObj(interp,tclres,&a) != TCL_OK )
              return TclError(interp,"error in shape_create: can not get amplitude result for index %d",j);
           RFshapes[slot][j].ampl = a;
        }
     } else if (!strcmp(argv[i],"-phase")) {
        i++;
        /* evaluate expression in Tcl */
        for (j=1; j<=len; j++) {
           sprintf(expr,"\n set i %d\n expr %s\n", j, argv[i]);
           if ( Tcl_EvalEx(interp, expr, -1,TCL_EVAL_DIRECT) != TCL_OK ) 
              return TclError(interp,"error in shape_create: can not evaluate %s for index %d",argv[i], j);
           tclres = Tcl_GetObjResult(interp);
           if ( Tcl_GetDoubleFromObj(interp,tclres,&p) != TCL_OK )
              return TclError(interp,"error in shape_create: can not get amplitude result for index %d",j);
           RFshapes[slot][j].phase = p;
        }
     }
  }   

  sprintf(interp->result,"%d",slot);

  return TCL_OK;
}

static int windowToCanvas( Tcl_Interp *interp,
      int objc, Tcl_Obj * const objv[], CanvasParams *params, int reverse )
{
   Tcl_Obj *resList;
   int     noCoords, n;
   if( objc != 3 )
   {
      Tcl_WrongNumArgs( interp, 2, objv, 
            /* canvas windowToCanvas */
            "list-of-coordinates ?option val ...?" );
      return TCL_ERROR;
   }
   /* TODO  
         -only [xy]:          only x, y coordinates
         -pairs [true|false]: list of coordinate pairs (lists)
   */
   if( Tcl_ListObjLength( interp, objv[2], &noCoords ) != TCL_OK
         || ( noCoords % 2 ) )
   {
      Tcl_SetResult( interp, 
            "size of list-of-coordinates must be even", 
            TCL_STATIC );
      return TCL_ERROR;
   }
   resList = Tcl_NewListObj( 0, NULL );
   for( n = 0; n < noCoords; n += 2 )
   {
      Tcl_Obj *tp;
      double xw, yw, x, y;
      int ret = Tcl_ListObjIndex( interp, objv[2], n, &tp );
      if( ret == TCL_OK )
         ret = Tcl_GetDoubleFromObj( interp, tp, &xw );
      if( ret == TCL_OK )
         ret = Tcl_ListObjIndex( interp, objv[2], n + 1, &tp );
      if( ret == TCL_OK )
         ret = Tcl_GetDoubleFromObj( interp, tp, &yw );

      if( ret != TCL_OK )
      {
         Tcl_DecrRefCount( resList );  /* FIXME: is this correct? */
         return TCL_ERROR;
      }
      if( reverse )
         gnome_canvas_world_to_window( params->canvas, xw, yw, &x, &y );
      else
         gnome_canvas_window_to_world( params->canvas, xw, yw, &x, &y );
      Tcl_ListObjAppendElement( interp, resList, Tcl_NewDoubleObj( x ) );
      Tcl_ListObjAppendElement( interp, resList, Tcl_NewDoubleObj( y ) );
   }
   Tcl_SetObjResult( interp, resList );

   return TCL_OK;
}

static void parse_args_obj_set(cli_args *a, char *store, Tcl_Obj *val) {
    if (a->type == ARG_OBJ) {
	*((Tcl_Obj **)&store[a->offset]) = val;
    } else if (a->type == ARG_STR) {
	*((char **)&store[a->offset]) = Tcl_GetStringFromObj(val, NULL);
    } else if (a->type == ARG_IO) {
	GapIO *io = io_from_obj(val);
	*((GapIO **)&store[a->offset]) = io;
    } else if (a->type == ARG_INT) {
	int i;

	if (Tcl_GetIntFromObj(NULL, val, &i) == TCL_OK) {	
	    *((int *)&store[a->offset]) = i;
	} else {
	    *((int *)&store[a->offset]) =
		atoi(Tcl_GetStringFromObj(val, NULL));
	}
    } else if (a->type == ARG_REC) {
	Tcl_WideInt i;

	if (Tcl_GetWideIntFromObj(NULL, val, &i) == TCL_OK) {	
	    *((tg_rec *)&store[a->offset]) = i;
	} else {
	    *((tg_rec *)&store[a->offset]) =
		atorec(Tcl_GetStringFromObj(val, NULL));
	}
    } else if (a->type == ARG_FLOAT) {
	double d;

	if (Tcl_GetDoubleFromObj(NULL, val, &d) == TCL_OK) {
	    *((float *)&store[a->offset]) = d;
	} else {
	    *((float *)&store[a->offset]) =
		atof(Tcl_GetStringFromObj(val, NULL));
	}
    } else if (a->type == ARG_DOUBLE) {
	double d;

	if (Tcl_GetDoubleFromObj(NULL, val, &d) == TCL_OK) {
	    *((double *)&store[a->offset]) = d;
	} else {
	    *((double *)&store[a->offset]) =
		atof(Tcl_GetStringFromObj(val, NULL));
	}
    } else {
	fprintf(stderr, "Unknown argument type %d\n", a->type);
    }

    a->def = ""; /* mark as used */
}

/* void draw_circleMeter_f3 (ESContext *esContext, float x, float y, float z, float radius, float start1, float start2, float start3, float start4, float value, char *text, char *text2, uint8_t type) { */
int tclcmd_draw_circleMeter_f3 (ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
    int len = 0;
    if (objc != 13) {
        Tcl_WrongNumArgs (interp, 1, objv, "{ESContext *esContext} { float x} { float y} { float z} { float radius} { float start1} { float start2} { float start3} { float start4} { float value} { char *text} { char *text2} { uint8_t type}");
        return TCL_ERROR;
    }
    double arg_x;
    if (Tcl_GetDoubleFromObj(interp, objv[1], (double *)&arg_x) != TCL_OK) {
        return TCL_ERROR;
    }
    double arg_y;
    if (Tcl_GetDoubleFromObj(interp, objv[2], (double *)&arg_y) != TCL_OK) {
        return TCL_ERROR;
    }
    double arg_z;
    if (Tcl_GetDoubleFromObj(interp, objv[3], (double *)&arg_z) != TCL_OK) {
        return TCL_ERROR;
    }
    double arg_radius;
    if (Tcl_GetDoubleFromObj(interp, objv[4], (double *)&arg_radius) != TCL_OK) {
        return TCL_ERROR;
    }
    double arg_start1;
    if (Tcl_GetDoubleFromObj(interp, objv[5], (double *)&arg_start1) != TCL_OK) {
        return TCL_ERROR;
    }
    double arg_start2;
    if (Tcl_GetDoubleFromObj(interp, objv[6], (double *)&arg_start2) != TCL_OK) {
        return TCL_ERROR;
    }
    double arg_start3;
    if (Tcl_GetDoubleFromObj(interp, objv[7], (double *)&arg_start3) != TCL_OK) {
        return TCL_ERROR;
    }
    double arg_start4;
    if (Tcl_GetDoubleFromObj(interp, objv[8], (double *)&arg_start4) != TCL_OK) {
        return TCL_ERROR;
    }
    double arg_value;
    if (Tcl_GetDoubleFromObj(interp, objv[9], (double *)&arg_value) != TCL_OK) {
        return TCL_ERROR;
    }
    char arg_text[1024];
    strncpy(arg_text, Tcl_GetStringFromObj(objv[10], &len), 1024);
    char arg_text2[1024];
    strncpy(arg_text2, Tcl_GetStringFromObj(objv[11], &len), 1024);
    uint8_t arg_type;
    if (Tcl_GetIntFromObj(interp, objv[12], (int *)&arg_type) != TCL_OK) {
        return TCL_ERROR;
    }
    draw_circleMeter_f3(GlobalesContext, (float)arg_x, (float)arg_y, (float)arg_z, (float)arg_radius, (float)arg_start1, (float)arg_start2, (float)arg_start3, (float)arg_start4, (float)arg_value, arg_text, arg_text2, arg_type);
    return TCL_OK;
}

double
TclObject::getDouble () const
{
    double value;
    Tcl_GetDoubleFromObj(0, m_pObj, &value);
    return value;
}

Tk_PathDash *
TkPathDashNew(Tcl_Interp *interp, Tcl_Obj *dashObjPtr)
{
    Tk_PathDash *dashPtr;
    int objc, i;
    double value;
    Tcl_Obj **objv;
    
    dashPtr = (Tk_PathDash *) ckalloc(sizeof(Tk_PathDash));
    dashPtr->number = 0;
    dashPtr->array = NULL;
    if (Tcl_ListObjGetElements(interp, dashObjPtr, &objc, (Tcl_Obj ***) &objv) != TCL_OK) {
	goto error;
    }
    dashPtr->number = objc;
    dashPtr->array = (float *) ckalloc(objc * sizeof(float));
    for (i = 0; i < objc; i++) {
	if (Tcl_GetDoubleFromObj(interp, objv[i], &value) != TCL_OK) {
	    goto error;
	}
	dashPtr->array[i] = (float) value;
    }
    return dashPtr;
    
error:
    TkPathDashFree(dashPtr);
    return NULL;
}

static QVariant
getValue(Tcl_Obj* object)
{
    if (object == NULL) return QVariant();
    return QString::fromUtf8(Tcl_GetString(object));

// TODO: should use the type to return a more accurate QVariant
#if 0
    if (object->typePtr == NULL)
	return QString::fromUtf8(Tcl_GetString(object));

    QString type(object->typePtr->name);
    if (type == "int") {
	int val;
	if (Tcl_GetIntFromObj(NULL, object, &val) == TCL_OK)
	    return val;
    } else if (type == "double") {
	double val;
	if (Tcl_GetDoubleFromObj(NULL, object, &val) == TCL_OK)
	    return val;
    }

    return QString::fromUtf8(Tcl_GetString(object));
#endif
}

int parse_ivector (Tcl_Obj * const obj, std::vector<int> &vec, Tcl_Interp *interp, bool fromDouble)
{
    Tcl_Obj **data;
    int num;
    double d;

    if (Tcl_ListObjGetElements(interp, obj, &num, &data) != TCL_OK) {
        Tcl_SetResult(interp, (char *) "Cgmap: error parsing arguments", TCL_STATIC);
        return -1;
    }

    vec.resize(num);

    if (fromDouble == false) {
        for (int i = 0; i < num; i++) {
            if (Tcl_GetIntFromObj(interp, data[i], &vec[i]) != TCL_OK) {
                Tcl_SetResult(interp, (char *) "Cgmap: error parsing vector element as integer", TCL_STATIC);
                return -1;
            }
        }
    } else {
        // do a double-to-int conversion first
        for (int i = 0; i < num; i++) {
            if (Tcl_GetDoubleFromObj(interp, data[i], &d) != TCL_OK) {
                Tcl_SetResult(interp, (char *) "Cgmap: error parsing vector element as integer", TCL_STATIC);
                return -1;
            }
            vec[i] = int (d);
        }
    }
    return num;
}

static int LinTransitionSet(
    ClientData clientData,
    Tcl_Interp *interp,		/* Current interp; may be used for errors. */
    Tk_Window tkwin,		/* Window for which option is being set. */
    Tcl_Obj **value,		/* Pointer to the pointer to the value object.
				 * We use a pointer to the pointer because
				 * we may need to return a value (NULL). */
    char *recordPtr,		/* Pointer to storage for the widget record. */
    int internalOffset,		/* Offset within *recordPtr at which the
				 * internal value is to be stored. */
    char *oldInternalPtr,	/* Pointer to storage for the old value. */
    int flags)			/* Flags for the option, set Tk_SetOptions. */
{
    char *internalPtr;
    int objEmpty = 0;
    Tcl_Obj *valuePtr;
    double z[4] = {0.0, 0.0, 1.0, 0.0};		/* Defaults according to SVG. */
    PathRect *newrc = NULL;
    
    valuePtr = *value;
    internalPtr = ComputeSlotAddress(recordPtr, internalOffset);
    objEmpty = ObjectIsEmpty(valuePtr);
    
    /*
     * Important: the new value for the transition is not yet 
     * stored into the style! transObj may be NULL!
     * The new value is stored in style *after* we return TCL_OK.
     */
    if ((flags & TK_OPTION_NULL_OK) && objEmpty) {
        valuePtr = NULL;
    } else {
        int i, len;
        Tcl_Obj **objv;
        
        if (Tcl_ListObjGetElements(interp, valuePtr, &len, &objv) != TCL_OK) {
            return TCL_ERROR;
        }
        if (len != 4) {
            Tcl_SetObjResult(interp, Tcl_NewStringObj(
                    "-lineartransition must have four elements", -1));
            return TCL_ERROR;
        }
        for (i = 0; i < 4; i++) {
            if (Tcl_GetDoubleFromObj(interp, objv[i], z+i) != TCL_OK) {
                return TCL_ERROR;
            }
        }
        newrc = (PathRect *) ckalloc(sizeof(PathRect));
        newrc->x1 = z[0];
        newrc->y1 = z[1];
        newrc->x2 = z[2];
        newrc->y2 = z[3];
    }
    if (internalPtr != NULL) {
        *((PathRect **) oldInternalPtr) = *((PathRect **) internalPtr);
        *((PathRect **) internalPtr) = newrc;
    }
    return TCL_OK;
}