SchemeSmobAtom.cc

Go to the documentation of this file.

/*
 * SchemeSmobAtom.c
 *
 * Scheme small objects (SMOBS) for opencog atom properties
 *
 * Copyright (c) 2008,2009 Linas Vepstas <linas@linas.org>
 */

#ifdef HAVE_GUILE

#include <vector>

#include <cstddef>
#include <libguile.h>

#include <opencog/atomspace/ClassServer.h>
#include <opencog/atomspace/TruthValue.h>
#include <opencog/guile/SchemeSmob.h>

using namespace opencog;

/* ============================================================== */
Handle SchemeSmob::verify_handle (SCM satom, const char * subrname, int pos)
{
    Handle h(scm_to_handle(satom));
    if (Handle::UNDEFINED == h)
        scm_wrong_type_arg_msg(subrname, pos, satom, "opencog atom");

    return h;
}

/* ============================================================== */
SCM SchemeSmob::ss_name (SCM satom)
{
    std::string name;
    Handle h = verify_handle(satom, "cog-name");
    NodePtr nnn(NodeCast(h));
    if (nnn) name = nnn->getName();
    SCM str = scm_from_utf8_string(name.c_str());
    return str;
}

SCM SchemeSmob::ss_type (SCM satom)
{
    Handle h = verify_handle(satom, "cog-type");
    Type t = h->getType();
    const std::string &tname = classserver().getTypeName(t);
    SCM str = scm_from_utf8_string(tname.c_str());
    SCM sym = scm_string_to_symbol(str);

    return sym;
}

SCM SchemeSmob::ss_arity (SCM satom)
{
    Handle h = verify_handle(satom, "cog-arity");
    Arity ari = 0;
    LinkPtr lll(LinkCast(h));
    if (lll) ari = lll->getArity();

    /* Arity is currently an unsigned short */
    SCM sari = scm_from_ushort(ari);
    return sari;
}

SCM SchemeSmob::ss_tv (SCM satom)
{
    Handle h = verify_handle(satom, "cog-tv");
    TruthValuePtr tv(h->getTruthValue());
    TruthValue *stv = tv->rawclone();
    return take_tv(stv);
}

SCM SchemeSmob::ss_set_tv (SCM satom, SCM stv)
{
    Handle h = verify_handle(satom, "cog-set-tv!");
    TruthValue *tv = verify_tv(stv, "cog-set-tv!", 2);

    h->setTruthValue(tv->clone());
    scm_remember_upto_here_1(stv);
    return satom;
}

SCM SchemeSmob::ss_av (SCM satom)
{
    Handle h = verify_handle(satom, "cog-av");
    AttentionValue *sav = h->getAttentionValue()->rawclone();
    return take_av(sav);
}

SCM SchemeSmob::ss_set_av (SCM satom, SCM sav)
{
    Handle h = verify_handle(satom, "cog-set-av!");
    AttentionValue *av = verify_av(sav, "cog-set-av!", 2);

    h->setAttentionValue(av->clone());
    return satom;
}

SCM SchemeSmob::ss_inc_vlti (SCM satom)
{
    Handle h = verify_handle(satom, "cog-inc-vlti!");

    h->incVLTI();
    return satom;
}

SCM SchemeSmob::ss_dec_vlti (SCM satom)
{
    Handle h = verify_handle(satom, "cog-dec-vlti!");

    h->decVLTI();
    return satom;
}

/* ============================================================== */
SCM SchemeSmob::ss_outgoing_set (SCM satom)
{
    Handle h = verify_handle(satom, "cog-outgoing-set");

    LinkPtr lll(LinkCast(h));
    if (NULL == lll) return SCM_EOL;

    const HandleSeq& oset = lll->getOutgoingSet();

    SCM list = SCM_EOL;
    for (int i = oset.size()-1; i >= 0; i--)
    {
        Handle h = oset[i];
        SCM smob = handle_to_scm(h);
        list = scm_cons (smob, list);
    }

    return list;
}

/* ============================================================== */
SCM SchemeSmob::ss_incoming_set (SCM satom)
{
    Handle h = verify_handle(satom, "cog-incoming-set");

    // This reverses the order of the incoming set, but so what ...
    SCM head = SCM_EOL;
    IncomingSet iset = h->getIncomingSet();
    for (const LinkPtr& l : iset)
    {
        SCM smob = handle_to_scm(l->getHandle());
        head = scm_cons(smob, head);
    }

    return head;
}

/* ============================================================== */

SCM SchemeSmob::ss_map_type (SCM proc, SCM stype)
{
    Type t = verify_atom_type (stype, "cog-map-type");
    AtomSpace* atomspace = ss_get_env_as("cog-map-type");

    // Get all of the handles of the indicated type
    std::list<Handle> handle_set;
    atomspace->get_handles_by_type(back_inserter(handle_set), t, false);

    // Loop over all handles in the handle set.
    // Call proc on each handle, in turn.
    // Break out of the loop if proc returns anything other than #f
    std::list<Handle>::iterator i;
    for (i = handle_set.begin(); i != handle_set.end(); ++i) {
        Handle h = *i;
        SCM smob = handle_to_scm(h);
        SCM rc = scm_call_1(proc, smob);
        if (!scm_is_false(rc)) return rc;
    }

    return SCM_BOOL_F;
}

/* ============================================================== */

SCM SchemeSmob::ss_get_types (void)
{
    SCM list = SCM_EOL;

    Type t = classserver().getNumberOfClasses();
    while (1) {
        t--;
        const std::string &tname = classserver().getTypeName(t);
        SCM str = scm_from_utf8_string(tname.c_str());
        SCM sym = scm_string_to_symbol(str);
        list = scm_cons(sym, list);
        if (0 == t) break;
    }

    return list;
}

SCM SchemeSmob::ss_get_subtypes (SCM stype)
{
    SCM list = SCM_EOL;

    Type t = verify_atom_type(stype, "cog-get-subtypes");
    std::vector<Type> subl;
    unsigned int ns = classserver().getChildren(t, std::back_inserter(subl));

    for (unsigned int i=0; i<ns; i++) {
        t = subl[i];
        const std::string &tname = classserver().getTypeName(t);
        SCM str = scm_from_utf8_string(tname.c_str());
        SCM sym = scm_string_to_symbol(str);
        list = scm_cons(sym, list);
    }

    return list;
}

SCM SchemeSmob::ss_get_type (SCM stype)
{
    if (scm_is_true(scm_symbol_p(stype)))
        stype = scm_symbol_to_string(stype);

    static_assert(2 == sizeof(Type),
        "*** Code currently assumes types are shorts!  ***");

    if (scm_is_false(scm_string_p(stype)))
        return scm_from_ushort(NOTYPE);

    const char * ct = scm_i_string_chars(stype);
    Type t = classserver().getType(ct);

    return scm_from_ushort(t);
}

SCM SchemeSmob::ss_type_p (SCM stype)
{
    if (scm_is_integer(stype)) {
        Type t = scm_to_ushort(stype);
        if (classserver().isValid(t))
            return SCM_BOOL_T;
        return SCM_BOOL_F;
    }

    if (scm_is_true(scm_symbol_p(stype)))
        stype = scm_symbol_to_string(stype);

    if (scm_is_false(scm_string_p(stype)))
        return SCM_BOOL_F;

    const char * ct = scm_i_string_chars(stype);
    Type t = classserver().getType(ct);

    if (NOTYPE == t) return SCM_BOOL_F;

    return SCM_BOOL_T;
}

SCM SchemeSmob::ss_node_type_p (SCM stype)
{
    if (scm_is_integer(stype)) {
        Type t = scm_to_ushort(stype);
        if (classserver().isNode(t))
            return SCM_BOOL_T;
        return SCM_BOOL_F;
    }

    if (scm_is_true(scm_symbol_p(stype)))
        stype = scm_symbol_to_string(stype);

    if (scm_is_false(scm_string_p(stype)))
        return SCM_BOOL_F;

    const char * ct = scm_i_string_chars(stype);
    Type t = classserver().getType(ct);

    if (NOTYPE == t) return SCM_BOOL_F;
    if (false == classserver().isA(t, NODE)) return SCM_BOOL_F;

    return SCM_BOOL_T;
}

SCM SchemeSmob::ss_link_type_p (SCM stype)
{
    if (scm_is_integer(stype)) {
        Type t = scm_to_ushort(stype);
        if (classserver().isLink(t))
            return SCM_BOOL_T;
        return SCM_BOOL_F;
    }

    if (scm_is_true(scm_symbol_p(stype)))
        stype = scm_symbol_to_string(stype);

    if (scm_is_false(scm_string_p(stype)))
        return SCM_BOOL_F;

    const char * ct = scm_i_string_chars(stype);
    Type t = classserver().getType(ct);

    if (NOTYPE == t) return SCM_BOOL_F;
    if (false == classserver().isA(t, LINK)) return SCM_BOOL_F;

    return SCM_BOOL_T;
}

SCM SchemeSmob::ss_subtype_p (SCM stype, SCM schild)
{
    if (scm_is_true(scm_symbol_p(stype)))
        stype = scm_symbol_to_string(stype);

    if (scm_is_false(scm_string_p(stype)))
        return SCM_BOOL_F;

    const char * ct = scm_i_string_chars(stype);
    Type parent = classserver().getType(ct);

    if (NOTYPE == parent) return SCM_BOOL_F;

    // Now investigate the child ...
    if (scm_is_true(scm_symbol_p(schild)))
        schild = scm_symbol_to_string(schild);

    if (scm_is_false(scm_string_p(schild)))
        return SCM_BOOL_F;

    const char * cht = scm_i_string_chars(schild);
    Type child = classserver().getType(cht);

    if (NOTYPE == child) return SCM_BOOL_F;

    if (classserver().isA(child, parent)) return SCM_BOOL_T;

    return SCM_BOOL_F;
}

#endif

/* ===================== END OF FILE ============================ */