/**
* Given some kind of Scheme string value, convert it to a C string
* If scmval is not a string value, returns NULL.
*/
static char *
scheme_object_to_string (Scheme_Object *scmval)
{
char *str = NULL;
// Char strings are the normal Scheme strings. They need to be
// converted to byte strings.
if (SCHEME_CHAR_STRINGP (scmval))
{
scmval = scheme_char_string_to_byte_string_locale (scmval);
str = SCHEME_BYTE_STR_VAL (scmval);
} // if it's a char string
// Byte strings are easy, but not the typical Scheme strings.
else if (SCHEME_BYTE_STRINGP (scmval))
{
str = SCHEME_BYTE_STR_VAL (scmval);
} // if it's a byte string
// A design decision: We'll treat symbols as strings. (It certainly
// makes things easier for the client.)
else if (SCHEME_SYMBOLP (scmval))
{
str = SCHEME_SYM_VAL (scmval);
} // if it's a symbol
// Everything else is not a string
else
{
// Signal an error by setting the return value to NULL.
str = NULL;
} // if it's not a string
return str;
} // scheme_object_to_string
/**
* Convert a Scheme_Object to a string. Returns NULL if it fails.
*/
char *
tostring (Scheme_Object *obj)
{
if (SCHEME_BYTE_STRINGP (obj))
return SCHEME_BYTE_STR_VAL (obj);
else if (SCHEME_CHAR_STRINGP (obj))
return SCHEME_BYTE_STR_VAL (scheme_char_string_to_byte_string (obj));
else
return NULL;
} // tostring
/**
* Convert a Scheme_Object to a string. Returns NULL if it fails.
*/
char *
tostring (Scheme_Object *obj)
{
if (SCHEME_BYTE_STRINGP (obj))
return SCHEME_BYTE_STR_VAL (obj);
else if (SCHEME_CHAR_STRINGP (obj))
// (scheme_char_string_to_byte_string) to be able to convert it to byte string
return SCHEME_BYTE_STR_VAL (scheme_char_string_to_byte_string (obj));
else
return NULL;
} // tostring
static Scheme_Object *catch_eval_error(int argc, Scheme_Object **argv)
{
Scheme_Object *bs;
if (!SCHEME_CHAR_STRINGP(argv[0]))
scheme_wrong_type("eval-string/catch-error", "string", 0, argc, argv);
bs = scheme_char_string_to_byte_string(argv[0]);
return eval_string_or_get_exn_message(SCHEME_BYTE_STR_VAL(bs));
}
static Scheme_Object *
immutablep (int argc, Scheme_Object *argv[])
{
Scheme_Object *v = argv[0];
return ((!SCHEME_INTP(v)
&& SCHEME_IMMUTABLEP(v)
&& (SCHEME_PAIRP(v)
|| SCHEME_VECTORP(v)
|| SCHEME_BYTE_STRINGP(v)
|| SCHEME_CHAR_STRINGP(v)
|| SCHEME_BOXP(v)))
? scheme_true
: scheme_false);
}
/**
* Determine whether we can convert a Scheme_Object to a string.
*/
int
stringp (Scheme_Object *obj)
{
return SCHEME_BYTE_STRINGP (obj) || SCHEME_CHAR_STRINGP (obj);
} // stringp
/**
*Translating the scheme_object to gvariant type for the client
*This step is used on sending input values onto the DBus
*/
GVariant *
scheme_obj_to_gvariant (Scheme_Object *list)
{
GVariantBuilder *builder;
GVariant *finalr;
GVariant *rvalue = NULL;
Scheme_Object *firstelement;
int length = 0;
gint32 i;
char* rstring;
double rdouble;
builder = g_variant_builder_new(G_VARIANT_TYPE_TUPLE);
length = scheme_list_length (list);
// rvalue = g_new(GVariant *, length);
if (length == 0)
{
// scheme_signal_error("length 0");
return rvalue ;
} // if
else{
while (length != 0)
{
// Get the first element of the argument
firstelement = scheme_car (list);
list = scheme_cdr(list);
length = scheme_list_length(list);
// checking the scheme_type to see whether it is an integer or not
// Eventually see if we can convert this to a switch statement.
if (SCHEME_INTP (firstelement))
{
// we saved the return value at &i
i = SCHEME_INT_VAL(firstelement);
rvalue = g_variant_new ("i",i);
g_variant_builder_add_value(builder,rvalue);
// return rvalue;
} // if it's an integer
else if (SCHEME_BYTE_STRINGP (firstelement)|| SCHEME_CHAR_STRINGP(firstelement))
{
//scheme_signal_error ("We are in Character");
//getting the string out of the scheme_object
rstring = SCHEME_BYTE_STR_VAL(list);
// we will convert it to g_variant
rvalue = g_variant_new ("(&s)", rstring);
g_variant_builder_add_value(builder, rvalue);
} // if it's a character
else if (SCHEME_TYPE (firstelement) == scheme_double_type)
{
//getting the double out of the scheme_object
rdouble = scheme_real_to_double(list);
// we will convert it to g_variant
rvalue = g_variant_new_double(rdouble);
g_variant_builder_add_value(builder, rvalue);
} // if it's a double
} // while loop
finalr = g_variant_builder_end (builder);
return finalr;
} //else
return finalr;
} // scheme_obj_to_gvariant
void TpMzScheme::evalDesign(Design::Ptr d){
DesignStore::Ptr ds = Game::getGame()->getDesignStore();
if (scheme_setjmp(scheme_error_buf)) {
Logger::getLogger()->warning("MzScheme Error");
} else {
Scheme_Object* temp;
std::ostringstream formater;
formater.str("");
formater << "(define-values (struct:designType make-designType designType? designType-ref designType-set!)(make-design-type "
<< ds->getMaxPropertyId() << "))";
temp = scheme_eval_string(formater.str().c_str(), env);
temp = scheme_eval_string("(define property-designType-set! (lambda (design id val) (designType-set! design (- id 1) val)))", env);
std::set<uint32_t> propids = ds->getPropertyIds();
for(std::set<uint32_t>::iterator propit = propids.begin();
propit != propids.end(); ++propit){
// for each property type
Property::Ptr p = ds->getProperty(*propit);
if(p){
formater.str("");
formater << "(define designType." << p->getName()
<< " (make-property-accessor designType-ref "
<< p->getPropertyId() << " \"" << p->getName()
<< "\" ))";
temp = scheme_eval_string(formater.str().c_str(), env);
}
}
propids.clear();
IdMap complist = d->getComponents();
temp = scheme_eval_string("(define design (make-designType))", env);
for(std::set<uint32_t>::iterator propit = propids.begin();
propit != propids.end(); ++propit){
formater.str("");
formater << "(property-designType-set! design "
<< *propit << " 0.0)";
temp = scheme_eval_string(formater.str().c_str(), env);
}
std::map<uint32_t, std::map<uint32_t, std::list<std::string> > > propranking;
for(IdMap::iterator compit = complist.begin();
compit != complist.end(); ++compit){
Component::Ptr c = ds->getComponent(compit->first);
std::map<uint32_t, std::string> pilist = c->getPropertyList();
for(std::map<uint32_t, std::string>::iterator piit = pilist.begin();
piit != pilist.end(); ++piit){
Property::Ptr p = ds->getProperty(piit->first);
for(uint32_t i = 0; i < compit->second; i++){
propranking[p->getRank()][p->getPropertyId()].push_back(piit->second);
}
}
}
std::map<uint32_t, PropertyValue> propertyvalues;
for(std::map<uint32_t, std::map<uint32_t, std::list<std::string> > >::iterator rpiit = propranking.begin();
rpiit != propranking.end(); ++rpiit){
std::map<uint32_t, std::list<std::string> > pilist = rpiit->second;
std::set<PropertyValue> localvalues;
for(std::map<uint32_t, std::list<std::string> >::iterator piit = pilist.begin();
piit != pilist.end(); ++piit){
PropertyValue propval(piit->first,0.0);
std::list<double> listvals;
std::list<std::string> lambdas = piit->second;
for(std::list<std::string>::iterator itlamb = lambdas.begin();
itlamb != lambdas.end(); ++itlamb){
temp = scheme_eval_string((std::string("(") + (*itlamb) + " design)").c_str(), env);
if(!SCHEME_NUMBERP(temp)){
Logger::getLogger()->warning("MzScheme: Return not a number");
}else{
listvals.push_back(scheme_real_to_double(temp));
}
}
Property::Ptr p = ds->getProperty(piit->first);
formater.str("");
formater << "(" << p->getTpclDisplayFunction() << " design '(";
for(std::list<double>::iterator itvals = listvals.begin();
itvals != listvals.end(); ++itvals){
formater << *itvals << " ";
}
formater << "))";
temp = scheme_eval_string(formater.str().c_str(), env);
#ifdef HAVE_MZSCHEME20X
if(!SCHEME_PAIRP(temp) || !SCHEME_NUMBERP(SCHEME_CAR(temp)) || !SCHEME_STRINGP(SCHEME_CDR(temp))){
#else
if(!SCHEME_PAIRP(temp) || !SCHEME_NUMBERP(SCHEME_CAR(temp)) || !SCHEME_CHAR_STRINGP(SCHEME_CDR(temp))){
#endif
Logger::getLogger()->warning("MzScheme: Return not a pair, or the wrong time in the pair");
}else{
propval.setValue(scheme_real_to_double(SCHEME_CAR(temp)));
#ifdef HAVE_MZSCHEME20X
propval.setDisplayString(std::string(SCHEME_STR_VAL(SCHEME_CDR(temp))));
#else
propval.setDisplayString(std::string((char*)SCHEME_CHAR_STR_VAL(SCHEME_CDR(temp))));
#endif
localvalues.insert(propval);
}
}
for(std::set<PropertyValue>::iterator pvit = localvalues.begin();
pvit != localvalues.end(); ++pvit){
PropertyValue pv = *pvit;
formater.str("");
formater << "(property-designType-set! design "
<< pv.getPropertyId() << " " << pv.getValue()
<< ")";
temp = scheme_eval_string(formater.str().c_str(), env);
propertyvalues[pv.getPropertyId()] = pv;
}
}
d->setPropertyValues(propertyvalues);
// now check if the design is valid
bool valid = true;
std::string feedback = "";
Logger::getLogger()->debug("About to process requirement functions");
for(IdMap::iterator compit = complist.begin();
compit != complist.end();
++compit){
uint32_t curval = compit->first;
//for each component in the design
temp = scheme_eval_string((std::string("(") + ds->getComponent(curval)->getTpclRequirementsFunction() + " design)").c_str(), env);
#ifdef HAVE_MZSCHEME20X
if(!SCHEME_PAIRP(temp) || !SCHEME_STRINGP(SCHEME_CDR(temp))){
#else
if(!SCHEME_PAIRP(temp) || !SCHEME_CHAR_STRINGP(SCHEME_CDR(temp))){
#endif
Logger::getLogger()->warning("MzScheme: (a) Return not a pair, or the wrong time in the pair");
}else{
valid &= SCHEME_TRUEP(SCHEME_CAR(temp));
#ifdef HAVE_MZSCHEME20X
std::string strtemp = SCHEME_STR_VAL(SCHEME_CDR(temp));
#else
std::string strtemp = (char*)SCHEME_CHAR_STR_VAL(SCHEME_CDR(temp));
#endif
if(strtemp.length() > 0)
feedback += strtemp + " ";
}
}
for(std::map<uint32_t, std::map<uint32_t, std::list<std::string> > >::iterator rpiit = propranking.begin();
rpiit != propranking.end(); ++rpiit){
std::map<uint32_t, std::list<std::string> > pilist = rpiit->second;
for(std::map<uint32_t, std::list<std::string> >::iterator piit = pilist.begin();
piit != pilist.end(); ++piit){
temp = scheme_eval_string((std::string("(") + ds->getProperty(piit->first)->getTpclRequirementsFunction() + " design)").c_str(), env);
#ifdef HAVE_MZSCHEME20X
if(!SCHEME_PAIRP(temp) || !SCHEME_STRINGP(SCHEME_CDR(temp))){
#else
if(!SCHEME_PAIRP(temp) || !SCHEME_CHAR_STRINGP(SCHEME_CDR(temp))){
#endif
Logger::getLogger()->warning("MzScheme: (a) Return not a pair, or the wrong time in the pair");
}else{
valid &= SCHEME_TRUEP(SCHEME_CAR(temp));
#ifdef HAVE_MZSCHEME20X
std::string strtemp = SCHEME_STR_VAL(SCHEME_CDR(temp));
#else
std::string strtemp = (char*)SCHEME_CHAR_STR_VAL(SCHEME_CDR(temp));
#endif
if(strtemp.length() > 0)
feedback += strtemp + " ";
}
}
}
propranking.clear();
d->setValid(valid, feedback);
Logger::getLogger()->debug("Eval'ed design");
if(!valid){
Logger::getLogger()->debug("Design %s is not valid, reason: %s", d->getName().c_str(), feedback.c_str());
}
}
}
TpMzScheme::TpMzScheme(){
//scheme_set_stack_base(NULL, 1); /* required for OS X, only. WILL NOT WORK HERE */
bool loaded = false;
env = scheme_basic_env();
if (scheme_setjmp(scheme_error_buf)) {
Logger::getLogger()->warning("MzScheme warning: could not load local file, trying installed file");
} else {
scheme_eval_string("(load \"../modules/tpcl/mzscheme/designstruct.scm\")",env);
loaded = true;
}
if(loaded == false){
if (scheme_setjmp(scheme_error_buf)) {
Logger::getLogger()->warning("MzScheme warning: could not load installed file");
} else {
scheme_eval_string("(load \"" DATADIR "/tpserver/tpscheme/mzscheme/designstruct.scm\")", env);
loaded = true;
}
}
if(loaded == false){
Logger::getLogger()->error("MzScheme Error: failed to load designstruct.scm file");
//throw exception?
}
}
