database.c

/*
 * plang logic programming language
 * Copyright (C) 2011  Southern Storm Software, Pty Ltd.
 *
 * The plang package is free software: you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation, either version 3 of
 * the License, or (at your option) any later version.
 *
 * The plang package is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with the libcompiler library.  If not,
 * see <http://www.gnu.org/licenses/>.
 */

#include <plang/database.h>
#include "database-priv.h"
#include "context-priv.h"
#include "rbtree-priv.h"

/*\@{*/

void _p_db_init(p_context *context)
{
    struct p_db_op_info
    {
        const char *name;
        p_op_specifier specifier;
        int priority;
    };
    static struct p_db_op_info const ops[] = {
        /* Traditional operators from ISO Prolog */
        {":-",      P_OP_XFX, 1200},
        {"-->",     P_OP_XFX, 1200},
        {":-",      P_OP_FX,  1200},
        {"?-",      P_OP_FX,  1200},
        {";",       P_OP_XFY, 1100},
        {"->",      P_OP_XFY, 1050},
        {",",       P_OP_XFY, 1000},
        {"\\+",     P_OP_FY,   900},
        {"=",       P_OP_XFX,  700},
        {"\\=",     P_OP_XFX,  700},
        {"==",      P_OP_XFX,  700},
        {"\\==",    P_OP_XFX,  700},
        {"@<",      P_OP_XFX,  700},
        {"@=<",     P_OP_XFX,  700},
        {"@>",      P_OP_XFX,  700},
        {"@>=",     P_OP_XFX,  700},
        {"=..",     P_OP_XFX,  700},
        {"is",      P_OP_XFX,  700},
        {"=:=",     P_OP_XFX,  700},
        {"=\\=",    P_OP_XFX,  700},
        {"<",       P_OP_XFX,  700},
        {"=<",      P_OP_XFX,  700},
        {">",       P_OP_XFX,  700},
        {">=",      P_OP_XFX,  700},
        {"+",       P_OP_YFX,  500},
        {"-",       P_OP_YFX,  500},
        {"/\\",     P_OP_YFX,  500},
        {"\\/",     P_OP_YFX,  500},
        {"*",       P_OP_YFX,  400},
        {"/",       P_OP_YFX,  400},
        {"//",      P_OP_YFX,  400},
        {"rem",     P_OP_YFX,  400},
        {"mod",     P_OP_YFX,  400},
        {"<<",      P_OP_YFX,  400},
        {">>",      P_OP_YFX,  400},
        {"**",      P_OP_XFX,  200},
        {"^",       P_OP_XFY,  200},
        {"-",       P_OP_FY,   200},
        {"\\",      P_OP_FY,   200},

        /* Operators specific to this implementation that give
         * better C-style names to some of the above */
        {"||",      P_OP_XFY, 1100},    /* ; */
        {"&&",      P_OP_XFY, 1000},    /* , */
        {"!",       P_OP_FY,   900},    /* \+ */
        {"!=",      P_OP_XFX,  700},    /* \= */
        {"!==",     P_OP_XFX,  700},    /* \== */
        {"=!=",     P_OP_XFX,  700},    /* =\= */
        {"@<=",     P_OP_XFX,  700},    /* @=< */
        {"<=",      P_OP_XFX,  700},    /* =< */
        {"%",       P_OP_YFX,  400},    /* mod */
        {"~",       P_OP_FY,   200},    /* \ */

        /* New operators specific to this implementation */
        {"<=>",     P_OP_YFX, 1130},    /* Logical equivalence */ 
        {"=>",      P_OP_YFX, 1120},    /* Logical implication */ 
        {":=",      P_OP_XFX,  700},    /* Variable assignment */ 
        {":==",     P_OP_XFX,  700},    /* Backtrackable assignment */ 
        {"::=",     P_OP_XFX,  700},    /* Numeric assignment */ 
        {"::==",    P_OP_XFX,  700},    /* Backtrackable num assign */ 
        {"in",      P_OP_XFX,  700},    /* List membership test */
        {">>>",     P_OP_YFX,  400},    /* Unsigned shift right */

        {0,         0,           0}
    };
    int index;
    for (index = 0; ops[index].name; ++index) {
        p_db_set_operator_info
            (p_term_create_atom(context, ops[index].name),
             ops[index].specifier, ops[index].priority);
    }
}

P_INLINE p_database_info *p_db_find_arity(const p_term *atom, unsigned int arity)
{
    p_database_info *info = atom->atom.db_info;
    while (info && info->arity != arity)
        info = info->next;
    return info;
}

p_database_info *_p_db_find_arity(const p_term *atom, unsigned int arity)
{
    return p_db_find_arity(atom, arity);
}

P_INLINE p_database_info *p_db_create_arity(p_term *atom, unsigned int arity)
{
    p_database_info *info = p_db_find_arity(atom, arity);
    if (!info) {
        info = GC_NEW(p_database_info);
        if (!info)
            return 0;
        info->next = atom->atom.db_info;
        info->arity = arity;
        atom->atom.db_info = info;
    }
    return info;
}

p_database_info *_p_db_create_arity(p_term *atom, unsigned int arity)
{
    return p_db_create_arity(atom, arity);
}

p_op_specifier p_db_operator_info(const p_term *name, int arity, int *priority)
{
    p_database_info *info;

    /* Check that the name is actually an atom */
    name = p_term_deref(name);
    if (!name || name->header.type != P_TERM_ATOM) {
        *priority = 0;
        return P_OP_NONE;
    }

    /* Search for the arity's information block */
    info = p_db_find_arity(name, (unsigned int)arity);
    if (!info) {
        *priority = 0;
        return P_OP_NONE;
    }

    /* Return the operator details */
    *priority = (int)(info->op_priority);
    return (p_op_specifier)(info->op_specifier);
}

void p_db_set_operator_info(p_term *name, p_op_specifier specifier, int priority)
{
    unsigned int arity;
    p_database_info *info;

    /* Check that the name is actually an atom */
    name = p_term_deref(name);
    if (!name || name->header.type != P_TERM_ATOM)
        return;

    /* Determine the operator's arity from the specifier */
    switch (specifier) {
    case P_OP_XF:
    case P_OP_YF:
    case P_OP_FX:
    case P_OP_FY:   arity = 1; break;
    case P_OP_XFX:
    case P_OP_XFY:
    case P_OP_YFX:  arity = 2; break;
    default:        return;
    }

    /* Clear the operator details if setting the priority to zero */
    if (!priority)
        specifier = P_OP_NONE;

    /* Find or create an information block for the arity */
    info = p_db_create_arity(name, arity);
    if (!info)
        return;

    /* Set the operator details */
    info->op_specifier = (unsigned int)specifier;
    info->op_priority = (unsigned int)priority;
}

p_db_builtin p_db_builtin_predicate(const p_term *name, int arity)
{
    p_database_info *info;

    /* Check that the name is actually an atom */
    name = p_term_deref(name);
    if (!name || name->header.type != P_TERM_ATOM)
        return 0;

    /* Search for the arity's information block */
    info = p_db_find_arity(name, (unsigned int)arity);
    if (info)
        return info->builtin_func;
    else
        return 0;
}

void p_db_set_builtin_predicate(p_term *name, int arity, p_db_builtin builtin)
{
    p_database_info *info;

    /* Check that the name is actually an atom */
    name = p_term_deref(name);
    if (!name || name->header.type != P_TERM_ATOM)
        return;

    /* Find or create an information block for the arity */
    info = p_db_create_arity(name, (unsigned int)arity);
    if (!info)
        return;

    /* Set the builtin */
    info->builtin_func = builtin;
    if (builtin)
        info->flags |= P_PREDICATE_BUILTIN;
    else
        info->flags &= ~P_PREDICATE_BUILTIN;
}

/* Register a table of builtin predicates */
void _p_db_register_builtins(p_context *context, const struct p_builtin *builtins)
{
    while (builtins->name != 0) {
        p_db_set_builtin_predicate
            (p_term_create_atom(context, builtins->name),
             builtins->arity, builtins->func);
        ++builtins;
    }
}

p_db_arith p_db_builtin_arith(const p_term *name, int arity)
{
    p_database_info *info;

    /* Check that the name is actually an atom */
    name = p_term_deref(name);
    if (!name || name->header.type != P_TERM_ATOM)
        return 0;

    /* Search for the arity's information block */
    info = p_db_find_arity(name, (unsigned int)arity);
    if (info)
        return info->arith_func;
    else
        return 0;
}

void p_db_set_builtin_arith
    (p_term *name, int arity, p_db_arith builtin)
{
    p_database_info *info;

    /* Check that the name is actually an atom */
    name = p_term_deref(name);
    if (!name || name->header.type != P_TERM_ATOM)
        return;

    /* Find or create an information block for the arity */
    info = p_db_create_arity(name, (unsigned int)arity);
    if (!info)
        return;

    /* Set the arithmetic builtin */
    info->arith_func = builtin;
}

/* Register a table of builtin arithmetic functions */
void _p_db_register_ariths(p_context *context, const struct p_arith *ariths)
{
    while (ariths->name != 0) {
        p_db_set_builtin_arith
            (p_term_create_atom(context, ariths->name),
             ariths->arity, ariths->arith_func);
        ++ariths;
    }
}

/* Register a table of Plang source strings for builtin predicates */
void _p_db_register_sources(p_context *context, const char * const *sources)
{
    while (*sources != 0) {
        p_context_consult_string(context, *sources);
        ++sources;
    }
}

/* Extract the predicate name and arity from a clause */
static p_term *p_db_predicate_name
    (p_context *context, p_term *clause, int *arity)
{
    p_term *head;
    clause = p_term_deref(clause);
    if (!clause || clause->header.type != P_TERM_FUNCTOR ||
            clause->header.size != 2 ||
            clause->functor.functor_name != context->clause_atom)
        return 0;
    head = p_term_deref(clause->functor.arg[0]);
    if (!head)
        return 0;
    if (head->header.type == P_TERM_ATOM) {
        *arity = 0;
        return head;
    } else if (head->header.type == P_TERM_FUNCTOR) {
        *arity = (int)(head->header.size);
        return head->functor.functor_name;
    }
    return 0;
}

/* Convert a clause from (:-)/2 form into P_TERM_CLAUSE form */
P_INLINE p_term *p_db_convert_clause(p_context *context, p_term *clause)
{
    return p_term_create_dynamic_clause
        (context, p_term_arg(clause, 0), p_term_arg(clause, 1));
}

int p_db_clause_assert_first(p_context *context, p_term *clause)
{
    p_database_info *info;
    p_term *name;
    int arity;
    p_term *predicate;

    /* Fetch the clause name and arity */
    name = p_db_predicate_name(context, clause, &arity);
    if (!name)
        return 0;

    /* Find or create the information block for the arity */
    info = p_db_create_arity(name, (unsigned int)arity);
    if (!info)
        return 0;

    /* Bail out if the predicate is builtin or compiled */
    if (info->flags & (P_PREDICATE_BUILTIN | P_PREDICATE_COMPILED))
        return 0;

    /* Add the clause to the head of the list */
    predicate = info->predicate;
    if (!predicate) {
        predicate = p_term_create_predicate(context, name, arity);
        if (!predicate)
            return 0;
        info->predicate = predicate;
    }
    p_term_add_clause_first
        (context, predicate, p_db_convert_clause(context, clause));
    return 1;
}

/* Assert a clause and return the predicate it was asserted into */
p_term *_p_db_clause_assert_last(p_context *context, p_term *clause)
{
    p_database_info *info;
    p_term *name;
    int arity;
    p_term *predicate;

    /* Fetch the clause name and arity */
    name = p_db_predicate_name(context, clause, &arity);
    if (!name)
        return 0;

    /* Find or create the information block for the arity */
    info = p_db_create_arity(name, (unsigned int)arity);
    if (!info)
        return 0;

    /* Bail out if the predicate is builtin or compiled */
    if (info->flags & (P_PREDICATE_BUILTIN | P_PREDICATE_COMPILED))
        return 0;

    /* Add the clause to the tail of the list */
    predicate = info->predicate;
    if (!predicate) {
        predicate = p_term_create_predicate(context, name, arity);
        if (!predicate)
            return 0;
        info->predicate = predicate;
    }
    p_term_add_clause_last
        (context, predicate, p_db_convert_clause(context, clause));
    return predicate;
}

int p_db_clause_assert_last(p_context *context, p_term *clause)
{
    return _p_db_clause_assert_last(context, clause) != 0;
}

int p_db_clause_retract(p_context *context, p_term *clause)
{
    p_database_info *info;
    p_term *name;
    int arity;
    struct p_term_clause *list;
    struct p_term_clause *prev;
    p_term *predicate;

    /* Fetch the clause name and arity */
    name = p_db_predicate_name(context, clause, &arity);
    if (!name)
        return 0;

    /* Find the information block for the arity */
    info = p_db_find_arity(name, (unsigned int)arity);
    if (!info)
        return -1;

    /* Bail out if the predicate is builtin or compiled */
    if (info->flags & (P_PREDICATE_BUILTIN | P_PREDICATE_COMPILED))
        return 0;

    /* Retract the first clause that unifies */
    predicate = info->predicate;
    if (!predicate)
        return -1;
    list = predicate->predicate.clauses.head;
    prev = 0;
    while (list) {
        if (_p_term_retract_clause(context, predicate, list, clause)) {
            if (prev)
                prev->next_clause = list->next_clause;
            else
                predicate->predicate.clauses.head = list->next_clause;
            --(predicate->predicate.clause_count);
            if (!list->next_clause)
                predicate->predicate.clauses.tail = prev;
            if (!predicate->predicate.clauses.head)
                info->predicate = 0;    /* Completely removed */
            return 1;
        }
        prev = list;
        list = list->next_clause;
    }
    return -1;
}

int p_db_clause_abolish(p_context *context, const p_term *name, int arity)
{
    p_database_info *info;

    /* Check that the name is actually an atom */
    name = p_term_deref(name);
    if (!name || name->header.type != P_TERM_ATOM)
        return 1;   /* Absolishing a non-existent clause succeeds */

    /* Find the information block for the arity */
    info = p_db_find_arity(name, (unsigned int)arity);
    if (!info)
        return 1;   /* Absolishing a non-existent clause succeeds */

    /* Bail out if the predicate is builtin or compiled */
    if (info->flags & (P_PREDICATE_BUILTIN | P_PREDICATE_COMPILED))
        return 0;

    /* Retract all of the clauses */
    info->predicate = 0;
    return 1;
}

int p_db_local_clause_assert_first(p_context *context, p_term *database, p_term *clause)
{
    p_database_info *info;
    p_term *name;
    int arity;
    p_term *predicate;
    p_rbkey key;
    p_rbnode *node;

    /* Check that we have a valid local database */
    database = p_term_deref(database);
    if (!database || database->header.type != P_TERM_DATABASE)
        return 0;

    /* Fetch the clause name and arity */
    name = p_db_predicate_name(context, clause, &arity);
    if (!name)
        return 0;

    /* Find the information block for the arity and check that
     * the predicate is not builtin */
    info = p_db_find_arity(name, (unsigned int)arity);
    if (info && (info->flags & P_PREDICATE_BUILTIN) != 0)
        return 0;

    /* Find the name within the local database's predicate tree */
    key.type = P_TERM_FUNCTOR;
    key.size = arity;
    key.name = name;
    node = _p_rbtree_insert(&(database->database.predicates), &key);
    if (!node)
        return 0;
    predicate = node->value;
    if (!predicate) {
        predicate = p_term_create_predicate(context, name, arity);
        if (!predicate)
            return 0;
        node->value = predicate;
    }

    /* Add the clause to the head of the list */
    p_term_add_clause_first
        (context, predicate, p_db_convert_clause(context, clause));
    return 1;
}

int p_db_local_clause_assert_last(p_context *context, p_term *database, p_term *clause)
{
    p_database_info *info;
    p_term *name;
    int arity;
    p_term *predicate;
    p_rbkey key;
    p_rbnode *node;

    /* Check that we have a valid local database */
    database = p_term_deref(database);
    if (!database || database->header.type != P_TERM_DATABASE)
        return 0;

    /* Fetch the clause name and arity */
    name = p_db_predicate_name(context, clause, &arity);
    if (!name)
        return 0;

    /* Find the information block for the arity and check that
     * the predicate is not builtin */
    info = p_db_find_arity(name, (unsigned int)arity);
    if (info && (info->flags & P_PREDICATE_BUILTIN) != 0)
        return 0;

    /* Find the name within the local database's predicate tree */
    key.type = P_TERM_FUNCTOR;
    key.size = arity;
    key.name = name;
    node = _p_rbtree_insert(&(database->database.predicates), &key);
    if (!node)
        return 1;   /* Absolishing a non-existent clause succeeds */
    predicate = node->value;
    if (!predicate) {
        predicate = p_term_create_predicate(context, name, arity);
        if (!predicate)
            return 0;
        node->value = predicate;
    }

    /* Add the clause to the tail of the list */
    p_term_add_clause_last
        (context, predicate, p_db_convert_clause(context, clause));
    return 1;
}

int p_db_local_clause_retract(p_context *context, p_term *database, p_term *clause)
{
    p_term *name;
    int arity;
    p_term *predicate;
    p_rbkey key;
    p_rbnode *node;
    struct p_term_clause *list;
    struct p_term_clause *prev;

    /* Check that we have a valid local database */
    database = p_term_deref(database);
    if (!database || database->header.type != P_TERM_DATABASE)
        return 0;

    /* Fetch the clause name and arity */
    name = p_db_predicate_name(context, clause, &arity);
    if (!name)
        return 0;

    /* Find the name within the local database's predicate tree */
    key.type = P_TERM_FUNCTOR;
    key.size = arity;
    key.name = name;
    node = _p_rbtree_lookup(&(database->database.predicates), &key);
    if (!node)
        return -1;

    /* Retract the first clause that unifies */
    predicate = node->value;
    list = predicate->predicate.clauses.head;
    prev = 0;
    while (list) {
        if (_p_term_retract_clause(context, predicate, list, clause)) {
            if (prev)
                prev->next_clause = list->next_clause;
            else
                predicate->predicate.clauses.head = list->next_clause;
            --(predicate->predicate.clause_count);
            if (!list->next_clause)
                predicate->predicate.clauses.tail = prev;
            if (!predicate->predicate.clauses.head) {
                /* The predicate has been completely removed */
                _p_rbtree_remove
                    (&(database->database.predicates), &key);
            }
            return 1;
        }
        prev = list;
        list = list->next_clause;
    }
    return -1;
}

int p_db_local_clause_abolish(p_context *context, p_term *database, const p_term *name, int arity)
{
    p_rbkey key;

    /* Check that we have a valid local database */
    database = p_term_deref(database);
    if (!database || database->header.type != P_TERM_DATABASE)
        return 0;

    /* Check that the name is actually an atom */
    name = p_term_deref(name);
    if (!name || name->header.type != P_TERM_ATOM)
        return 1;   /* Absolishing a non-existent clause succeeds */

    /* Find the name within the local database's predicate tree */
    key.type = P_TERM_FUNCTOR;
    key.size = arity;
    key.name = name;
    if (!_p_rbtree_lookup(&(database->database.predicates), &key))
        return 1;   /* Absolishing a non-existent clause succeeds */

    /* Remove the predicate from the tree, which abolishs all clauses */
    _p_rbtree_remove(&(database->database.predicates), &key);
    return 1;
}

p_predicate_flags p_db_predicate_flags(p_context *context, const p_term *name, int arity)
{
    p_database_info *info;

    /* Check that the name is actually an atom */
    name = p_term_deref(name);
    if (!name || name->header.type != P_TERM_ATOM)
        return P_PREDICATE_NONE;

    /* Search for the arity's information block */
    info = p_db_find_arity(name, (unsigned int)arity);
    if (!info)
        return P_PREDICATE_NONE;

    /* Return the predicate flag details */
    return (p_predicate_flags)(info->flags);
}

void p_db_set_predicate_flag(p_context *context, p_term *name, int arity, p_predicate_flags flag, int value)
{
    p_database_info *info;

    /* Check that the name is actually an atom */
    name = p_term_deref(name);
    if (!name || name->header.type != P_TERM_ATOM)
        return;

    /* Find or create an information block for the arity */
    info = p_db_create_arity(name, arity);
    if (!info)
        return;

    /* Alter the specified flag */
    if (value)
        info->flags |= flag;
    else
        info->flags &= ~flag;
}

/*\@}*/

---