/* struct::set - critcl - layer 3 definitions.
 *
 * -> Set functions.
 *    Implementations for all set commands.
 */

#include "s.h"
#include "m.h"

/* .................................................. */

/*
 *---------------------------------------------------------------------------
 *
 * sm_ADD --
 *
 *	Copies the argument tree over into this tree object. Uses direct
 *	access to internal data structures for matching tree objects, and
 *	goes through a serialize/deserialize combination otherwise.
 *
 * Results:
 *	A standard Tcl result code.
 *
 * Side effects:
 *	Only internal, memory allocation changes ...
 *
 *---------------------------------------------------------------------------
 */

int
sm_ADD (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: set add SETVAR SET
     *	       [0] [1] [2]    [3]
     */

    SPtr        vs, s;
    Tcl_Obj*    val;
    int         new = 0;

    if (objc != 4) {
	Tcl_WrongNumArgs (interp, 2, objv, "Avar B");
	return TCL_ERROR;
    }

    if (s_get (interp, objv[3], &s) != TCL_OK) {
	return TCL_ERROR;
    }

    val = Tcl_ObjGetVar2(interp, objv[2], NULL, 0);
    if (val == NULL) {
	/* Create missing variable */

	vs  = s_dup (NULL);
	val = s_new (vs);
	(void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);

    } else if (s_get (interp, val, &vs) != TCL_OK) {
	return TCL_ERROR;
    }

    if (s->el.numEntries) {
	int            new, nx = 0;
	Tcl_HashSearch hs;
	Tcl_HashEntry* he;
	CONST char*    key;

	for(he = Tcl_FirstHashEntry(&s->el, &hs);
	    he != NULL;
	    he = Tcl_NextHashEntry(&hs)) {
	    key = Tcl_GetHashKey (&s->el, he);
	    if (Tcl_FindHashEntry (&vs->el, key) != NULL) continue;
	    /* Key not known to vs, to be added */

	    /* _Now_ unshare the object, if required */

	    if (Tcl_IsShared (val)) {
		val = Tcl_DuplicateObj (val);
		(void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);
		s_get (interp, val, &vs);
	    }

	    (void*) Tcl_CreateHashEntry(&vs->el, key, &new);
	    nx = 1;
	}
	if (nx) {
	    Tcl_InvalidateStringRep(val);
	}
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * sm_CONTAINS --
 *
 *	Copies this tree over into the argument tree. Uses direct access to
 *	internal data structures for matching tree objects, and goes through a
 *	serialize/deserialize combination otherwise.
 *
 * Results:
 *	A standard Tcl result code.
 *
 * Side effects:
 *	Only internal, memory allocation changes ...
 *
 *---------------------------------------------------------------------------
 */

int
sm_CONTAINS (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: set contains SET ITEM
     *	       [0] [1]      [2] [3]
     */

    SPtr        s;
    CONST char* item;

    if (objc != 4) {
	Tcl_WrongNumArgs (interp, 2, objv, "set item");
	return TCL_ERROR;
    }

    if (s_get (interp, objv[2], &s) != TCL_OK) {
	return TCL_ERROR;
    }

    item = Tcl_GetString (objv [3]);

    Tcl_SetObjResult (interp,
		      Tcl_NewIntObj (s_contains (s, item)));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * sm_DIFFERENCE --
 *
 *	Returns a list containing the ancestors of the named node.
 *
 * Results:
 *	A standard Tcl result code.
 *
 * Side effects:
 *	May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
sm_DIFFERENCE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: set difference SETa SETb
     *	       [0] [1]        [2]  [3]
     */

    SPtr sa, sb;

    if (objc != 4) {
	Tcl_WrongNumArgs (interp, 2, objv, "A B");
	return TCL_ERROR;
    }

    if (s_get (interp, objv[2], &sa) != TCL_OK) {
	return TCL_ERROR;
    }
    if (s_get (interp, objv[3], &sb) != TCL_OK) {
	return TCL_ERROR;
    }

    Tcl_SetObjResult (interp,
		      s_new (s_difference (sa, sb)));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * sm_EMPTY --
 *
 *	Appends a value to an attribute of the named node.
 *	May create the attribute.
 *
 * Results:
 *	A standard Tcl result code.
 *
 * Side effects:
 *	May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
sm_EMPTY (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: set empty SET
     *	       [0] [1]   [2]
     */

    SPtr s;

    if (objc != 3) {
	Tcl_WrongNumArgs (interp, 2, objv, "set");
	return TCL_ERROR;
    }

    if (objv[2]->typePtr == s_ltype ()) {
	int       lc;
	Tcl_Obj** lv;
	Tcl_ListObjGetElements(interp, objv[2], &lc, &lv);
	Tcl_SetObjResult (interp, Tcl_NewIntObj (lc == 0));
	return TCL_OK;
    }

    if (s_get (interp, objv[2], &s) != TCL_OK) {
	return TCL_ERROR;
    }

    Tcl_SetObjResult (interp,
		      Tcl_NewIntObj (s_empty (s)));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * sm_EQUAL --
 *
 *	Returns a dictionary mapping from nodes to attribute values, for a
 *	named attribute.
 *
 * Results:
 *	A standard Tcl result code.
 *
 * Side effects:
 *	May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
sm_EQUAL (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: set equal SETa SETb
     *	       [0] [1]   [2]  [3]
     */

    SPtr sa, sb;

    if (objc != 4) {
	Tcl_WrongNumArgs (interp, 2, objv, "A B");
	return TCL_ERROR;
    }

    if (s_get (interp, objv[2], &sa) != TCL_OK) {
	return TCL_ERROR;
    }
    if (s_get (interp, objv[3], &sb) != TCL_OK) {
	return TCL_ERROR;
    }

    Tcl_SetObjResult (interp,
		      Tcl_NewIntObj (s_equal (sa, sb)));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * sm_EXCLUDE --
 *
 *	Returns a list of all direct or indirect descendants of the named
 *	node, possibly run through a Tcl command prefix for filtering.
 *
 * Results:
 *	A standard Tcl result code.
 *
 * Side effects:
 *	May release and allocate memory. Per the filter command prefix, if
 *	one has been specified.
 *
 *---------------------------------------------------------------------------
 */

int
sm_EXCLUDE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: set exclude SETVAR ITEM
     *	       [0] [1]     [2]    [3]
     */

    SPtr        vs;
    Tcl_Obj*    val;
    char*       key;

    if (objc != 4) {
	Tcl_WrongNumArgs (interp, 2, objv, "Avar element");
	return TCL_ERROR;
    }

    val = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG);
    if (val == NULL) {
	return TCL_ERROR;
    }
    if (s_get (interp, val, &vs) != TCL_OK) {
	return TCL_ERROR;
    }

    key = Tcl_GetString (objv[3]);
    if (s_contains (vs, key)) {
	if (Tcl_IsShared (val)) {
	    val = Tcl_DuplicateObj (val);
	    (void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);
	    s_get (interp, val, &vs);
	}

	s_subtract1 (vs, key);
	Tcl_InvalidateStringRep(val);
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * sm_INCLUDE --
 *
 *	Deletes the named nodes, but not its children. They are put into the
 *	place where the deleted node was. Complementary to sm_SPLICE.
 *
 * Results:
 *	A standard Tcl result code.
 *
 * Side effects:
 *	May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
sm_INCLUDE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: set include SETVAR ITEM
     *	       [0] [1]     [2]    [3]
     */

    SPtr        vs;
    Tcl_Obj*    val;

    if (objc != 4) {
	Tcl_WrongNumArgs (interp, 2, objv, "Avar element");
	return TCL_ERROR;
    }

    val = Tcl_ObjGetVar2(interp, objv[2], NULL, 0);
    if (val == NULL) {
	/* Create missing variable */

	vs = s_dup (NULL);
	s_add1 (vs, Tcl_GetString (objv[3]));
	val = s_new (vs);

	(void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);
    } else {
	/* Extend variable */
	char* key;

	if (s_get (interp, val, &vs) != TCL_OK) {
	    return TCL_ERROR;
	}

	key = Tcl_GetString (objv[3]);
	if (!s_contains (vs, key)) {
	    if (Tcl_IsShared (val)) {
		val = Tcl_DuplicateObj (val);
		(void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);
		s_get (interp, val, &vs);
	    }

	    s_add1 (vs, key);
	    Tcl_InvalidateStringRep(val);
	}
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * sm_INTERSECT --
 *
 *	Deletes the named node and its children.
 *
 * Results:
 *	A standard Tcl result code.
 *
 * Side effects:
 *	May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
sm_INTERSECT (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: set intersect ?SET...?
     *	       [0] [1]       [2]
     */

    SPtr sa, sb, next, acc;
    int  i;

    if (objc == 2) {
	/* intersect nothing = nothing */
	Tcl_SetObjResult (interp, s_new (s_dup (NULL)));
	return TCL_OK;
    }

    for (i = 2; i < objc; i++) {
	if (s_get (interp, objv[i], &sa) != TCL_OK) {
	    return TCL_ERROR;
	}
    }

    s_get (interp, objv[2], &sa);

    if (objc == 3) {
	/* intersect with itself = unchanged */
	Tcl_SetObjResult (interp, s_new (s_dup (sa)));
	return TCL_OK;
    }

    acc = sa;
    for (i = 3; i < objc; i++) {
	s_get (interp, objv[i], &sb);
	next = s_intersect (acc, sb);
	if (acc != sa) s_free (acc);
	acc = next;
	if (s_empty (acc)) break;
    }

    if (acc == sa) {
	acc = s_dup (acc);
    }

    Tcl_SetObjResult (interp, s_new (acc));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * sm_INTERSECT3 --
 *
 *	Returns a non-negative integer number describing the distance between
 *	the named node and the root of the tree. A depth of 0 implies that
 *	the node is the root node.
 *
 * Results:
 *	A standard Tcl result code.
 *
 * Side effects:
 *	May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
sm_INTERSECT3 (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: set intersect3 SETa SETb
     *	       [0] [1]        [2]  [3]
     */

    SPtr sa, sb;
    Tcl_Obj* lv [3];

    if (objc != 4) {
	Tcl_WrongNumArgs (interp, 2, objv, "A B");
	return TCL_ERROR;
    }

    if (s_get (interp, objv[2], &sa) != TCL_OK) {
	return TCL_ERROR;
    }
    if (s_get (interp, objv[3], &sb) != TCL_OK) {
	return TCL_ERROR;
    }

    lv [0] = s_new (s_intersect  (sa, sb));
    lv [1] = s_new (s_difference (sa, sb));
    lv [2] = s_new (s_difference (sb, sa));

    Tcl_SetObjResult (interp, Tcl_NewListObj (3, lv));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * sm_SIZE --
 *
 *	Returns a list of all descendants of the named node, possibly run
 *	through a Tcl command prefix for filtering.
 *
 * Results:
 *	A standard Tcl result code.
 *
 * Side effects:
 *	May release and allocate memory. Per the filter command prefix, if
 *	one has been specified.
 *
 *---------------------------------------------------------------------------
 */

int
sm_SIZE (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: set size SET
     *	       [0] [1]  [2]
     */

    SPtr s;

    if (objc != 3) {
	Tcl_WrongNumArgs (interp, 2, objv, "set");
	return TCL_ERROR;
    }

    if (s_get (interp, objv[2], &s) != TCL_OK) {
	return TCL_ERROR;
    }

    Tcl_SetObjResult (interp,
		      Tcl_NewIntObj (s_size (s)));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * sm_SUBSETOF --
 *
 *	Parses a Tcl value containing a serialized tree and copies it over
 *	he existing tree.
 *
 * Results:
 *	A standard Tcl result code.
 *
 * Side effects:
 *	May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
sm_SUBSETOF (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: set subsetof SETa SETb
     *	       [0] [1]      [2]  [3]
     */

    SPtr sa, sb;

    if (objc != 4) {
	Tcl_WrongNumArgs (interp, 2, objv, "A B");
	return TCL_ERROR;
    }

    if (s_get (interp, objv[2], &sa) != TCL_OK) {
	return TCL_ERROR;
    }
    if (s_get (interp, objv[3], &sb) != TCL_OK) {
	return TCL_ERROR;
    }

    Tcl_SetObjResult (interp,
		      Tcl_NewIntObj (s_subsetof (sa, sb)));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * sm_SUBTRACT --
 *
 *	Destroys the whole tree object.
 *
 * Results:
 *	A standard Tcl result code.
 *
 * Side effects:
 *	Releases memory.
 *
 *---------------------------------------------------------------------------
 */

int
sm_SUBTRACT (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: set subtract SETVAR SET
     *	       [0] [1]      [2]    [3]
     */

    SPtr        vs, s;
    Tcl_Obj*    val;
    int         del;

    if (objc != 4) {
	Tcl_WrongNumArgs (interp, 2, objv, "Avar B");
	return TCL_ERROR;
    }

    val = Tcl_ObjGetVar2(interp, objv[2], NULL, TCL_LEAVE_ERR_MSG);
    if (val == NULL) {
	return TCL_ERROR;
    }
    if (s_get (interp, val, &vs) != TCL_OK) {
	return TCL_ERROR;
    }
    if (s_get (interp, objv[3], &s) != TCL_OK) {
	return TCL_ERROR;
    }

    if (s->el.numEntries) {
	int            new, dx = 0;
	Tcl_HashSearch hs;
	Tcl_HashEntry* he;
	CONST char*    key;

	for(he = Tcl_FirstHashEntry(&s->el, &hs);
	    he != NULL;
	    he = Tcl_NextHashEntry(&hs)) {
	    key = Tcl_GetHashKey (&s->el, he);
	    if (Tcl_FindHashEntry (&vs->el, key) == NULL) continue;
	    /* Key known to vs, to be removed */

	    /* _Now_ unshare the object, if required */

	    if (Tcl_IsShared (val)) {
		val = Tcl_DuplicateObj (val);
		(void) Tcl_ObjSetVar2 (interp, objv[2], NULL, val, 0);
		s_get (interp, val, &vs);
	    }

	    Tcl_DeleteHashEntry (Tcl_FindHashEntry (&vs->el, key));
	    dx = 1;
	}
	if (dx) {
	    Tcl_InvalidateStringRep(val);
	}
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * sm_SYMDIFF --
 *
 *	Returns a boolean value signaling whether the named node exists in
 *	the tree. True implies existence, and false non-existence.
 *
 * Results:
 *	A standard Tcl result code.
 *
 * Side effects:
 *	May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
sm_SYMDIFF (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: set symdiff SETa SETb
     *	       [0] [1]	   [2]  [3]
     */

    SPtr sa, sb, xa, xb, u;

    if (objc != 4) {
	Tcl_WrongNumArgs (interp, 2, objv, "A B");
	return TCL_ERROR;
    }

    if (s_get (interp, objv[2], &sa) != TCL_OK) {
	return TCL_ERROR;
    }
    if (s_get (interp, objv[3], &sb) != TCL_OK) {
	return TCL_ERROR;
    }

    if (s_get (interp, objv[2], &sa) != TCL_OK) {
	return TCL_ERROR;
    }
    if (s_get (interp, objv[3], &sb) != TCL_OK) {
	return TCL_ERROR;
    }

    xa = s_difference (sa, sb);
    xb = s_difference (sb, sa);
    u  = s_union      (xa, xb);

    s_free (xa);
    s_free (xb);

    Tcl_SetObjResult (interp, s_new (u));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * sm_UNION --
 *
 *	Returns the value of the named attribute at the given node.
 *
 * Results:
 *	A standard Tcl result code.
 *
 * Side effects:
 *	May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
sm_UNION (ClientData clientData, Tcl_Interp* interp, int objc, Tcl_Obj* CONST* objv)
{
    /* Syntax: set union ?SET...?
     *	       [0] [1]   [2]
     */

    SPtr sa, acc;
    int  i;

    if (objc == 2) {
	/* union nothing = nothing */
	Tcl_SetObjResult (interp, s_new (s_dup (NULL)));
	return TCL_OK;
    }

    for (i = 2; i < objc; i++) {
	if (s_get (interp, objv[i], &sa) != TCL_OK) {
	    return TCL_ERROR;
	}
    }

    acc = s_dup (NULL);

    for (i = 2; i < objc; i++) {
	s_get (interp, objv[i], &sa);
	s_add (acc, sa, NULL);
    }

    Tcl_SetObjResult (interp, s_new (acc));
    return TCL_OK;
}

/* .................................................. */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */