/*
* SchemeSmobNew.cc
*
* Scheme small objects (SMOBS) --creating new atoms -- for opencog.
*
* Copyright (c) 2008 Linas Vepstas <linas@linas.org>
*/
#include <vector>
#include <cstddef>
#include <libguile.h>
#include <opencog/atomspace/AtomSpace.h>
#include <opencog/atoms/atom_types/NameServer.h>
#include <opencog/atoms/core/NumberNode.h>
#include <opencog/atoms/foreign/ForeignAST.h>
#include <opencog/atoms/parallel/TriggerLink.h>
#include <opencog/guile/SchemeSmob.h>
using namespace opencog;
/* ============================================================== */
/**
* Return a string holding the scheme representation of an opencog object.
* This could be a Value including Atom, or an AtomSpace, or a
* guile module created with the PrimitiveEnviron C++ module wrapper.
*
* Returned is a valid scheme expression that represents that object.
*/
std::string SchemeSmob::to_string(SCM node)
{
if (SCM_SMOB_PREDICATE(SchemeSmob::cog_misc_tag, node))
return misc_to_string(node);
return "";
}
std::string SchemeSmob::protom_to_string(SCM node)
{
ValuePtr pa(scm_to_protom(node));
if (nullptr == pa) return "#<Invalid handle>";
// Need to have a newline printed; otherwise
// cog-value->list prints badly-formatted grunge.
if (not pa->is_atom())
return pa->to_string() + "\n";
// Avoid printing atoms that are not in any atomspace.
// Doing so, and more generally, keeping these around
// just leads to confusion on the part of the user.
// The current scheme bindings were designed to assume
// that atoms are always in some atomspace, and having
// free-floating atoms that aren't anywhere is not helpful
// for anyone, as far as I can tell.
// See issue opencog/atomspace#127 for one such report.
Handle h(HandleCast(pa));
if (nullptr == h->getAtomSpace())
{
if (ATOM_SPACE == h->get_type())
return h->to_string();
h = Handle::UNDEFINED;
SCM_SMOB_VALUE_PTR_LOC(node)->reset(); // std::shared_ptr<>::reset()
scm_remember_upto_here_1(node);
return "#<Invalid handle>";
}
// Need to have a newline printed; otherwise cog-value->list
// prints badly-formatted grunge.
return h->to_short_string() + "\n";
}
/* ============================================================== */
/**
* Wrapper -- given a handle, return the corresponding scheme object.
* Note that smobs hold the integer value of the handle, and not the
* C++ handle object itself.
*/
SCM SchemeSmob::handle_to_scm (const Handle& h)
{
return protom_to_scm(h);
}
SCM SchemeSmob::protom_to_scm (const ValuePtr& pa)
{
if (nullptr == pa) return SCM_BOOL_F;
SCM smob = scm_new_double_smob(cog_misc_tag, 0,0,0);
SCM_SET_SMOB_FLAGS(smob, COG_PROTOM);
*(SCM_SMOB_VALUE_PTR_LOC(smob)) = pa;
return smob;
}
ValuePtr SchemeSmob::scm_to_protom (SCM sh)
{
if (not SCM_SMOB_PREDICATE(SchemeSmob::cog_misc_tag, sh))
return nullptr;
scm_t_bits misctype = SCM_SMOB_FLAGS(sh);
if (COG_PROTOM != misctype)
return nullptr;
return *(SCM_SMOB_VALUE_PTR_LOC(sh));
}
Handle SchemeSmob::scm_to_handle (SCM sh)
{
ValuePtr pa(scm_to_protom(sh));
if (nullptr == pa)
return Handle::UNDEFINED;
if (not pa->is_atom())
return Handle::UNDEFINED;
Handle h(HandleCast(pa));
// Clobber deleted atoms (i.e. atoms that are no longer
// in any atomspace). The current guile interface was
// designed so that all atoms are in atomspaces, and any
// exceptions to this assumption leads to confusion and
// unexpected behavior -- i.e. leads to bugs.
if (nullptr == h->getAtomSpace() and
not (ATOM_SPACE == h->get_type()))
{
SCM_SMOB_VALUE_PTR_LOC(sh)->reset(); // std::shared_ptr<>::reset()
scm_remember_upto_here_1(sh);
return Handle::UNDEFINED;
}
scm_remember_upto_here_1(sh);
return h;
}
/* ============================================================== */
/**
* Return hash of atom
*/
SCM SchemeSmob::ss_handle (SCM satom)
{
Handle h(scm_to_handle(satom));
if (nullptr == h)
scm_wrong_type_arg_msg("cog-handle", 1, satom, "opencog atom");
return scm_from_ulong(h.value());
}
/** Return #t if left < right, else return #f. */
SCM SchemeSmob::ss_atom_less_p (SCM sleft, SCM sright)
{
Handle hleft(scm_to_handle(sleft));
Handle hright(scm_to_handle(sright));
if (nullptr == hleft)
scm_wrong_type_arg_msg("cog-atom-less?", 1, sleft, "opencog atom");
if (nullptr == hright)
scm_wrong_type_arg_msg("cog-atom-less?", 1, sright, "opencog atom");
if (hleft < hright) return SCM_BOOL_T;
return SCM_BOOL_F;
}
/** Return #t if the contents compare, else return #f. */
SCM SchemeSmob::ss_equal_p (SCM sleft, SCM sright)
{
ValuePtr vleft(scm_to_protom(sleft));
ValuePtr vright(scm_to_protom(sright));
if (vleft == vright) return SCM_BOOL_T;
if (nullptr == vleft) return SCM_BOOL_F;
if (nullptr == vright) return SCM_BOOL_F;
if (*vleft == *vright) return SCM_BOOL_T;
return SCM_BOOL_F;
}
/* ============================================================== */
/**
* Check that the argument is the string or symbol name of an atom,
* else throw errors.
* Return the atom type.
*/
Type SchemeSmob::verify_type (SCM stype, const char *subrname, int pos)
{
if (scm_is_integer(stype))
return scm_to_ushort(stype);
if (scm_is_true(scm_symbol_p(stype)))
stype = scm_symbol_to_string(stype);
if (scm_is_false(scm_string_p(stype)))
scm_wrong_type_arg_msg(subrname, pos, stype, "name of opencog atom type");
const char * ct = scm_i_string_chars(stype);
Type t = nameserver().getType(ct);
// Make sure that the type is good
if (NOTYPE == t)
scm_wrong_type_arg_msg(subrname, pos, stype, "name of opencog atom type");
return t;
}
/**
* Check that the argument is an int, else throw errors.
* Return the int.
*/
int SchemeSmob::verify_int (SCM sint, const char *subrname,
int pos, const char * msg)
{
if (scm_is_false(scm_integer_p(sint)))
scm_wrong_type_arg_msg(subrname, pos, sint, msg);
return scm_to_int(sint);
}
/**
* Check that the argument is a size_t, else throw errors.
*/
size_t SchemeSmob::verify_size_t (SCM ssizet, const char *subrname,
int pos, const char * msg)
{
if (scm_is_false(scm_integer_p(ssizet)))
scm_wrong_type_arg_msg(subrname, pos, ssizet, msg);
// Argh. New scheme won't allow -1 as size_t
// but it also doesn't provide a uintmax.
// return scm_to_size_t(ssizet);
return (size_t) scm_to_long(ssizet);
}
/**
* Check that the argument is a boolean constant, else throw errors.
* Return the bool.
*/
bool SchemeSmob::verify_bool (SCM sbool, const char *subrname,
int pos, const char * msg)
{
if (scm_is_bool(sbool))
return scm_to_bool(sbool);
else if (scm_is_integer(sbool))
return scm_to_int8(sbool);
else
scm_wrong_type_arg_msg(subrname, pos, sbool, msg);
return false; // not reached
}
/**
* Check that the argument is convertible to a real, else throw errors.
* Return as a float.
*/
double SchemeSmob::verify_real (SCM sreal, const char *subrname,
int pos, const char * msg)
{
if (scm_is_false(scm_real_p(sreal)))
scm_wrong_type_arg_msg(subrname, pos, sreal, msg);
return scm_to_double(sreal);
}
/**
* Check that the argument is a string, else throw errors.
* Return the string, in C.
*/
std::string SchemeSmob::verify_string (SCM sname, const char *subrname,
int pos, const char * msg)
{
if (not scm_is_string(sname))
scm_wrong_type_arg_msg(subrname, pos, sname, msg);
char* cname = scm_to_utf8_string(sname);
#define MASK(x) (x & 0xff)
// Search for unicode U+E000 to undo guile brain damage. Pitty.
// Life sucks. See notes on ss_name() for gory details.
size_t i=0;
while (cname[i])
{
if (0xee != MASK(cname[i])) i++;
else if (0x80 <= MASK(cname[i+1]) and 0x80 <= MASK(cname[i+2])) break;
}
std::string name;
name.assign(cname, i);
// Perhaps we are done. Phew.
if (0 == cname[i])
{
free(cname);
return name;
}
// If we are here, there is conversion to be done, undoing what
// ss_name did. Alas.
while (cname[i])
{
// Decode exactly one byte in the range U+E000 to U+E0FF
if (0xee == MASK(cname[i]) and
0x80 <= MASK(cname[i+1]) and MASK(cname[i+1]) < 0x84 and
0x80 <= MASK(cname[i+2]) and MASK(cname[i+2]) < 0xd0)
{
unsigned char c = 0x40 * (MASK(cname[i+1]) - 0x80) + (MASK(cname[i+2]) - 0x80);
name.push_back(c);
i += 3;
}
else
{
name.push_back(cname[i]);
i ++;
}
}
free(cname);
return name;
}
/* ============================================================== */
/**
* Copy an existing atom into a new atomspace.
*/
SCM SchemeSmob::ss_new_atom (SCM satom, SCM opt_as)
{
ValuePtr pa(verify_protom(satom, "cog-new-atom"));
if (not pa->is_atom())
scm_wrong_type_arg_msg("cog-new-atom", 1, satom, "opencog atom");
Handle h(HandleCast(pa));
const AtomSpacePtr& asg = get_as_from_list(opt_as);
const AtomSpacePtr& asp = asg ? asg :
ss_get_env_as("cog-new-atom");
try
{
return handle_to_scm(asp->add_atom(h));
}
catch (const std::exception& ex)
{
throw_exception(ex, "cog-new-atom", scm_cons(satom, opt_as));
}
scm_remember_upto_here_1(opt_as);
return SCM_EOL;
}
/**
* Return the indicated atom, if a version of it exists in this
* atomspace; else return nil if it does not exist.
*/
SCM SchemeSmob::ss_atom (SCM satom, SCM opt_as)
{
ValuePtr pa(verify_protom(satom, "cog-atom"));
if (not pa->is_atom())
scm_wrong_type_arg_msg("cog-atom", 1, satom, "opencog atom");
Handle h(HandleCast(pa));
const AtomSpacePtr& asg = get_as_from_list(opt_as);
const AtomSpacePtr& asp = asg ? asg :
ss_get_env_as("cog-atom");
try
{
return handle_to_scm(asp->get_atom(h));
}
catch (const std::exception& ex)
{
throw_exception(ex, "cog-atom", scm_cons(satom, opt_as));
}
scm_remember_upto_here_1(opt_as);
return SCM_EOL;
}
/* ============================================================== */
/**
* Create a new node, of named type stype, and string name sname
*/
SCM SchemeSmob::ss_new_node (SCM stype, SCM sname, SCM opt_numlist)
{
Type t = verify_type(stype, "cog-new-node", 1);
// Special case handling for NumberNode (and TimeNode, etc.)
std::string name;
if (nameserver().isA(t, NUMBER_NODE))
{
std::vector<double> vec;
SCM slist = SCM_EOL;
if (scm_is_number(sname))
{
slist = scm_cons(sname, opt_numlist);
}
else
if (scm_is_true(scm_list_p(sname)))
{
slist = sname;
}
if (not scm_is_null(slist))
{
while (scm_is_pair(slist))
{
SCM sval = SCM_CAR(slist);
if (scm_is_number(sval))
vec.push_back(scm_to_double(sval));
slist = SCM_CDR(slist);
}
name = NumberNode::vector_to_plain(vec);
}
}
else
// Allow symbols as well as strings for atom types.
if (nameserver().isA(t, TYPE_NODE) and scm_is_symbol(sname)) {
sname = scm_symbol_to_string(sname);
}
// Haven't set the string yet...
if (0 == name.size())
name = verify_string (sname, "cog-new-node", 2,
"string name for the node");
const AtomSpacePtr& asp = ss_get_env_as("cog-new-node");
try
{
// Now, create the actual node... in the actual atom space.
// This is a try-catch block, in case the AtomSpace is read-only.
Handle h(asp->add_node(t, std::move(name)));
return handle_to_scm(h);
}
catch (const std::exception& ex)
{
throw_exception(ex, "cog-new-node", scm_cons(sname, opt_numlist));
}
scm_remember_upto_here_1(opt_numlist);
return SCM_EOL;
}
/**
* Return the indicated node, of named type stype, and string name sname
* if it exists; else return nil if it does not exist.
* If the node exists, *and* a truth value was specified, then change
* the truth value.
*/
SCM SchemeSmob::ss_node (SCM stype, SCM sname, SCM opt_as)
{
Type t = verify_type(stype, "cog-node", 1);
if (not nameserver().isA(t, NODE))
scm_wrong_type_arg_msg("cog-node", 1, stype, "Node typename");
std::string name = verify_string (sname, "cog-node", 2,
"string name for the node");
const AtomSpacePtr& asg = get_as_from_list(opt_as);
const AtomSpacePtr& asp = asg ? asg :
ss_get_env_as("cog-node");
// Now, look for the actual node... in the actual AtomSpace.
Handle h(asp->get_node(t, std::string(name)));
if (nullptr == h) return SCM_BOOL_F;
scm_remember_upto_here_1(opt_as);
return handle_to_scm (h);
}
/* ============================================================== */
/*
* Helper function: a new AST, of named type stype, and string name sname
*/
Handle SchemeSmob::h_from_ast(Type t, bool rec, SCM sexpr)
{
// Recurse the quoted list
if (scm_is_pair(sexpr))
{
HandleSeq oset;
do
{
oset.emplace_back(h_from_ast(t, true, SCM_CAR(sexpr)));
sexpr = SCM_CDR(sexpr);
} while (scm_is_pair(sexpr));
return createForeignAST(std::move(oset), t);
}
std::string name;
if (scm_is_string(sexpr))
{
char * cname = scm_to_utf8_string(sexpr);
if (rec) name = "\"";
name += cname;
if (rec) name += "\"";
free(cname);
}
else if (scm_is_symbol(sexpr))
{
sexpr = scm_symbol_to_string(sexpr);
char * cname = scm_to_utf8_string(sexpr);
name = cname;
free(cname);
}
else
{
// Just a single atom.
Handle h(scm_to_handle(sexpr));
if (h)
{
if (rec) return h;
HandleSeq oset({h});
return createForeignAST(std::move(oset), t);
}
scm_wrong_type_arg_msg("cog-new-ast", 2, sexpr,
"expecting symbol, string or Atom");
}
// Try-catch, for two reasons:
// 1) Invalid syntax of the AST.
// 2) The AtomSpace may be read-only.
try
{
// Create the AST
return HandleCast(createForeignAST(t, name));
}
catch (const std::exception& ex)
{
throw_exception(ex, "cog-new-ast", sexpr);
}
return Handle(); // not reached
}
/**
* Create a new AST, of named type stype, and string name sname
*/
SCM SchemeSmob::ss_new_ast (SCM stype, SCM sexpr)
{
Type t = verify_type(stype, "cog-new-ast", 1);
const AtomSpacePtr& atomspace = ss_get_env_as("cog-new-ast");
// Try-catch, for two reasons:
// 1) Invalid syntax of the AST.
// 2) The AtomSpace may be read-only.
try
{
// Create the AST. Unwrap singleton strings, so they
// don't get confused by recursive constructions.
Handle h;
if (scm_is_pair(sexpr) and
scm_is_null(SCM_CDR(sexpr)) and
(scm_is_string(SCM_CAR(sexpr)) or
scm_equal_p(scm_sym_quote, SCM_CAR(sexpr)))
)
h = atomspace->add_atom(h_from_ast(t, false, SCM_CAR(sexpr)));
else
h = atomspace->add_atom(h_from_ast(t, false, sexpr));
return handle_to_scm(h);
}
catch (const std::exception& ex)
{
throw_exception(ex, "cog-new-ast", sexpr);
}
scm_remember_upto_here_1(sexpr);
return SCM_EOL;
}
/* ============================================================== */
/**
* Convert argument into a list of handles.
*/
HandleSeq
SchemeSmob::verify_handle_list_msg(SCM satom_list,
const char* subrname,
int pos,
const char* msglst,
const char* msgatm)
{
// Verify that second arg is an actual list. Allow null list
// (which is rather unusual, but legit.) Allow embedded nulls
// as this can be convenient for writing scheme code.
if (!scm_is_pair(satom_list) and !scm_is_null(satom_list))
scm_wrong_type_arg_msg(subrname, pos, satom_list, msglst);
HandleSeq outgoing_set;
SCM sl = satom_list;
pos = 2;
while (scm_is_pair(sl))
{
SCM satom = SCM_CAR(sl);
// Verify that the contents of the list are actual atoms.
Handle h(scm_to_handle(satom));
if (h)
{
outgoing_set.emplace_back(h);
}
else if (scm_is_pair(satom) and
not scm_is_null(satom_list))
{
// Allow lists to be specified: e.g.
// (cog-new-link 'ListLink (list x y z))
// Do this via a recursive call, flattening nested lists
// as we go along. The URE does this a lot.
const HandleSeq &oset =
verify_handle_list(satom, subrname, pos);
HandleSeq::const_iterator it;
for (it = oset.begin(); it != oset.end(); ++it) {
outgoing_set.emplace_back(*it);
}
}
else if (scm_is_null(satom))
{
// No-op, just ignore.
}
else
{
// Its legit to have embedded truth values, just skip them.
if (not SCM_SMOB_PREDICATE(SchemeSmob::cog_misc_tag, satom)) {
// If its not an atom, and its not a truth value, and
// its not an attention value, and its not an atomspace,
// then whatever it is, its bad.
scm_wrong_type_arg_msg(subrname, pos, satom, msgatm);
}
}
sl = SCM_CDR(sl);
pos++;
}
return outgoing_set;
}
HandleSeq
SchemeSmob::verify_handle_list(SCM satom_list, const char * subrname, int pos)
{
return verify_handle_list_msg(satom_list, subrname, pos,
"a list of Atoms", "an OpenCog Atom");
}
/**
* Create a new link, of named type stype, holding the indicated atom list
*/
SCM SchemeSmob::ss_new_link (SCM stype, SCM satom_list)
{
Type t = verify_type(stype, "cog-new-link", 1);
HandleSeq outgoing_set;
outgoing_set = verify_handle_list(satom_list, "cog-new-link", 2);
const AtomSpacePtr& atomspace = ss_get_env_as("cog-new-link");
try
{
// Now, create the actual link... in the actual atom space.
Handle h(atomspace->add_link(t, std::move(outgoing_set)));
return handle_to_scm(h);
}
catch (const ValueReturnException& ex)
{
if (nullptr == ex._value) return SCM_BOOL_F;
if (ex._value->is_atom())
return handle_to_scm(atomspace->add_atom(HandleCast(ex._value)));
return protom_to_scm(ex._value);
}
catch (const std::exception& ex)
{
throw_exception(ex, "cog-new-link", satom_list);
}
scm_remember_upto_here_1(satom_list);
return SCM_EOL;
}
/**
* Return the indicated link, of named type stype, holding the
* indicated atom list, if it exists; else return nil if
* it does not exist.
*/
SCM SchemeSmob::ss_link (SCM stype, SCM satom_list)
{
Type t = verify_type(stype, "cog-link", 1);
if (not nameserver().isA(t, LINK))
scm_wrong_type_arg_msg("cog-link", 1, stype, "Link typename");
HandleSeq outgoing_set;
outgoing_set = verify_handle_list (satom_list, "cog-link", 2);
const AtomSpacePtr& atomspace = ss_get_env_as("cog-link");
// Now, look to find the actual link... in the actual atom space.
Handle h(atomspace->get_link(t, std::move(outgoing_set)));
if (nullptr == h) return SCM_BOOL_F;
scm_remember_upto_here_1(satom_list);
return handle_to_scm (h);
}
/* ===================== END OF FILE ============================ */