Logo Search packages:      
Sourcecode: tcllib version File versions  Download package

methods.c

/* struct::tree - critcl - layer 3 definitions.
 *
 * -> Method functions.
 *    Implementations for all tree methods.
 */

#include <arc.h>
#include <graph.h>
#include <methods.h>
#include <nacommon.h>
#include <node.h>
#include <util.h>
#include <walk.h>

/* ..................................................
 * Handling of all indices, numeric and 'end-x' forms.  Copied straight out of
 * the Tcl core as this is not exported through the public API.
 */

static int TclGetIntForIndex (Tcl_Interp* interp, Tcl_Obj* objPtr,
                        int endValue, int* indexPtr);

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

#define FAIL(x) if (!(x)) { return TCL_ERROR; }

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

int
gm_GASSIGN (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph =   source
     *             [0]   [1] [2]
     */

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

    return g_ms_assign (interp, g, objv [2]);
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_GSET --
 *
 *    Copies this graph over into the argument graph. Uses direct access to
 *    internal data structures for matching graph objects, and goes through a
 *    serialize/deserialize combination otherwise.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    Only internal, memory allocation changes ...
 *
 *---------------------------------------------------------------------------
 */

int
gm_GSET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph --> dest(ination)
     *             [0]  [1]  [2]
     */

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

    return g_ms_set (interp, objv[0], g, objv [2]);
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_APPEND --
 *
 *    Appends a value to an attribute of the graph.
 *    May create the attribute.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_APPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph append key value
     *             [0]  [1]       [2]     [3]
     */

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

    g_attr_extend (&g->attr);
    g_attr_append  (g->attr, interp, objv[2], objv[3]);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_ARCS --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_ARCS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph arcs                       | all arcs
     *         graph arcs -in        NODE...    | arcs end in node in list
     *         graph arcs -out       NODE...    | arcs start in node in list
     *         graph arcs -adj       NODE...    | arcs start|end in node in list
     *         graph arcs -inner     NODE...    | arcs start&end in node in list
     *         graph arcs -embedding NODE...    | arcs start^end in node in list
     *         graph arcs -key       KEY        | arcs have attribute KEY
     *         graph arcs -value     VALUE      | arcs have KEY and VALUE
     *         graph arcs -filter    CMDPREFIX  | arcs for which CMD returns True.
     *             [0]   [1]  [2]        [3]
     *
     * -value requires -key.
     * -in/-out/-adj/-inner/-embedding are exclusive.
     * Each option can be used at most once.
     */

    return gc_filter (0, interp, objc, objv, &g->arcs,
                  (GN_GET_GC*) ga_get_arc, g);
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_arc_APPEND --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_arc_APPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph arc append ARC KEY VALUE
     *             [0]   [1] [2]    [3] [4] [5]
     */

    GA* a;

    if (objc != 6) {
      Tcl_WrongNumArgs (interp, 3, objv, "arc key value");
      return TCL_ERROR;
    }

    a = ga_get_arc (g, objv [3], interp, objv [0]);
    FAIL (a);

    g_attr_extend (&a->base.attr);
    g_attr_append  (a->base.attr, interp, objv[4], objv[5]);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_arc_ATTR --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_arc_ATTR (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph arc attr KEY
     *         graph arc attr KEY -arcs   LIST
     *         graph arc attr KEY -glob   PATTERN
     *         graph arc attr KEY -regexp PATTERN
     *             [0]   [1] [2]  [3] [4]     [5]
     */

    static const char* types [] = {
      "-arcs", "-glob","-regexp", NULL
    };
    int modes [] = {
      A_LIST, A_GLOB, A_REGEXP
    };

    int      mode;
    Tcl_Obj* detail;

    if ((objc != 4) && (objc != 6)) {
      Tcl_WrongNumArgs (interp, 3, objv,
                    "key ?-arcs list|-glob pattern|-regexp pattern?");
      return TCL_ERROR;
    }

    if (objc != 6) {
      detail = NULL;
      mode   = A_NONE;
    } else {
      detail = objv [5];
      if (Tcl_GetIndexFromObj (interp, objv [4], types, "type",
                         0, &mode) != TCL_OK) {
          return TCL_ERROR;
      }
      mode = modes [mode];
    }

    return gc_attr (&g->arcs, mode, detail, interp, objv[3],
                (GN_GET_GC*) ga_get_arc, g);
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_arc_DELETE --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_arc_DELETE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph arc  delete ARC ARC...
     *             [0]   [1]  [2]    [3] [4+]
     */

    GA* a;
    int i;

    if (objc < 4) {
      Tcl_WrongNumArgs (interp, 3, objv, "arc arc...");
      return TCL_ERROR;
    }

    for (i=3; i<objc; i++) {
      a = ga_get_arc (g, objv[i], interp, objv[0]);
      FAIL (a);
    }

    for (i=3; i<objc; i++) {
      a = ga_get_arc (g, objv[i], interp, objv[0]);
      ga_delete (a);
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_arc_EXISTS --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_arc_EXISTS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph arc exists NAME
     *             [0]   [1] [2]    [3]
     */

    GA* a;

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

    a = ga_get_arc (g, objv [3], NULL, NULL);

    Tcl_SetObjResult (interp, Tcl_NewIntObj (a != NULL));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_arc_FLIP --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_arc_FLIP (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph arc flip ARC
     *             [0]   [1] [2]  [3]
     */

    GA*     a;
    GN* src;
    GN* dst;

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

    a = ga_get_arc (g, objv [3], interp, objv [0]);
    FAIL (a);

    src = a->start->n;
    dst = a->end->n;

    if (src != dst) {
      ga_mv_src (a, dst);
      ga_mv_dst (a, src);
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_arc_GET --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_arc_GET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph arc get ARC KEY
     *             [0]   [1] [2] [3] [4]
     */

    GA* a;

    if (objc != 5) {
      Tcl_WrongNumArgs (interp, 3, objv, "arc key");
      return TCL_ERROR;
    }

    a = ga_get_arc (g, objv [3], interp, objv [0]);
    FAIL (a);

    return g_attr_get (a->base.attr, interp, objv[4],
                   objv [3], "\" for arc \"");
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_arc_GETALL --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_arc_GETALL (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph arc getall ARC ?PATTERN?
     *             [0]   [1] [2]    [3] [4]
     */

    GA* a;

    if ((objc != 4) && (objc != 5)) {
      Tcl_WrongNumArgs (interp, 3, objv, "arc ?pattern?");
      return TCL_ERROR;
    }

    a = ga_get_arc (g, objv [3], interp, objv [0]);
    FAIL (a);

    g_attr_getall (a->base.attr, interp, objc-4, objv+4);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_arc_INSERT --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_arc_INSERT (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph arc insert SOURCE TARGET ?ARC?
     *             [0]   [1] [2]    [3]    [4]    [5]
     */

    GN* src;
    GN* dst;
    GA* a;
    const char* name;

    if ((objc != 5) && (objc != 6)) {
      Tcl_WrongNumArgs (interp, 3, objv, "source target ?arc?");
      return TCL_ERROR;
    }

    Tcl_AppendResult (interp, "source ", NULL);
    src = gn_get_node (g, objv [3], interp, objv[0]);
    FAIL (src);
    Tcl_ResetResult (interp);

    Tcl_AppendResult (interp, "target ", NULL);
    dst = gn_get_node (g, objv [4], interp, objv[0]);
    FAIL (dst);
    Tcl_ResetResult (interp);

    if (objc == 6) {
      /* Explicit arc name, must not exist */

      if (ga_get_arc (g, objv [5], NULL, NULL)) {
          ga_err_duplicate (interp, objv[5], objv[0]);
          return TCL_ERROR;
      }

      /* No matching arc found */
      /* Create arc with specified name, */
      /* then insert it */
            
      name = Tcl_GetString (objv [5]);

    } else {
      /* Create a single new node with a generated name, */
      /* then insert it. */

      name = g_newarcname (g);
    }

    a = ga_new (g, name, src, dst);
    Tcl_SetObjResult (interp, Tcl_NewListObj (1, &a->base.name));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_arc_KEYEXISTS --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_arc_KEYEXISTS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph arc keyexists ARC KEY
     *             [0]   [1] [2]       [3] [4]
     */

    GA*     a;

    if (objc != 5) {
      Tcl_WrongNumArgs (interp, 3, objv, "arc key");
      return TCL_ERROR;
    }

    a = ga_get_arc (g, objv [3], interp, objv [0]);
    FAIL (a);

    g_attr_kexists (a->base.attr, interp, objv[4]);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_arc_KEYS --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_arc_KEYS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph arc keys ARC ?PATTERN?
     *             [0]  [1]    [2]  [3] [4]
     */

    GA* a;

    if ((objc != 4) && (objc != 5)) {
      Tcl_WrongNumArgs (interp, 3, objv, "arc ?pattern?");
      return TCL_ERROR;
    }

    a = ga_get_arc (g, objv [3], interp, objv [0]);
    FAIL (a);

    g_attr_keys (a->base.attr, interp, objc-4, objv+4);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_arc_LAPPEND --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_arc_LAPPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph arc lappend ARC KEY VALUE
     *             [0]   [1] [2]     [3] [4] [5]
     */

    GA* a;

    if (objc != 6) {
      Tcl_WrongNumArgs (interp, 3, objv, "arc key value");
      return TCL_ERROR;
    }

    a = ga_get_arc (g, objv [3], interp, objv [0]);
    FAIL (a);

    g_attr_extend (&a->base.attr);
    g_attr_lappend (a->base.attr, interp, objv[4], objv[5]);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_arc_MOVE --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_arc_MOVE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph arc move ARC NEWSRC NEWDST
     *             [0]   [1] [2]  [3] [4]    [5]
     */

    GA*     a;
    GN* nsrc;
    GN* ndst;

    if (objc != 6) {
      Tcl_WrongNumArgs (interp, 3, objv, "arc newsource newtarget");
      return TCL_ERROR;
    }

    a = ga_get_arc (g, objv [3], interp, objv [0]);
    FAIL (a);

    nsrc = gn_get_node (g, objv [4], interp, objv [0]);
    FAIL (nsrc);

    ndst = gn_get_node (g, objv [5], interp, objv [0]);
    FAIL (ndst);

    ga_mv_src (a, nsrc);
    ga_mv_dst (a, ndst);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_arc_MOVE_SRC --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_arc_MOVE_SRC (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph arc move ARC NEWSRC
     *             [0]   [1] [2]  [3] [4]
     */

    GA*     a;
    GN* nsrc;

    if (objc != 5) {
      Tcl_WrongNumArgs (interp, 3, objv, "arc newsource");
      return TCL_ERROR;
    }

    a = ga_get_arc (g, objv [3], interp, objv [0]);
    FAIL (a);

    nsrc = gn_get_node (g, objv [4], interp, objv [0]);
    FAIL (nsrc);

    ga_mv_src (a, nsrc);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_arc_MOVE_TARG --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_arc_MOVE_TARG (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph arc move ARC NEWDST
     *             [0]   [1] [2]  [3] [4]
     */

    GA*     a;
    GN* ndst;

    if (objc != 5) {
      Tcl_WrongNumArgs (interp, 3, objv, "arc newtarget");
      return TCL_ERROR;
    }

    a = ga_get_arc (g, objv [3], interp, objv [0]);
    FAIL (a);

    ndst = gn_get_node (g, objv [4], interp, objv [0]);
    FAIL (ndst);

    ga_mv_dst (a, ndst);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_arc_RENAME --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_arc_RENAME (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph arc rename ARC NEW
     *             [0]   [1] [2]    [3] [4]
     */

    GC* c;

    if (objc != 5) {
      Tcl_WrongNumArgs (interp, 3, objv, "arc newname");
      return TCL_ERROR;
    }

    c = (GC*) ga_get_arc (g, objv [3], interp, objv [0]);
    FAIL (c);

    if (ga_get_arc (g, objv [4], NULL, NULL)) {
      ga_err_duplicate (interp, objv[4], objv[0]);
      return TCL_ERROR;
    }

    gc_rename (c, &g->arcs, objv[4], interp);
    ga_shimmer_self ((GA*) c);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_arc_SET --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_arc_SET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph arc set ARC KEY ?VALUE?
     *             [0]   [1] [2] [3] [4] [5]
     */

    GA* a;

    if ((objc != 5) && (objc != 6)) {
      Tcl_WrongNumArgs (interp, 3, objv, "arc key ?value?");
      return TCL_ERROR;
    }

    a = ga_get_arc (g, objv [3], interp, objv [0]);
    FAIL (a);

    if (objc == 5) {
      return g_attr_get (a->base.attr, interp, objv[4],
                     objv [3], "\" for arc \"");
    } else {
      g_attr_extend (&a->base.attr);
      g_attr_set     (a->base.attr, interp, objv[4], objv[5]);
      return TCL_OK;
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_arc_SOURCE --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_arc_SOURCE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph arc source ARC
     *             [0]   [1] [2]    [3]
     */

    GA* a;

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

    a = ga_get_arc (g, objv [3], interp, objv [0]);
    FAIL (a);

    Tcl_SetObjResult (interp, a->start->n->base.name);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_arc_TARGET --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_arc_TARGET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph arc target ARC
     *             [0]   [1] [2]    [3]
     */

    GA* a;

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

    a = ga_get_arc (g, objv [3], interp, objv [0]);
    FAIL (a);

    Tcl_SetObjResult (interp, a->end->n->base.name);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_arc_UNSET --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_arc_UNSET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph arc unset ARC KEY
     *             [0]   [1] [2]   [3] [4]
     */

    GA* a;

    if (objc != 5) {
      Tcl_WrongNumArgs (interp, 3, objv, "arc key");
      return TCL_ERROR;
    }

    a = ga_get_arc (g, objv [3], interp, objv [0]);
    FAIL (a);

    g_attr_unset (a->base.attr, objv [4]);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_DESERIALIZE --
 *
 *    Parses a Tcl value containing a serialized graph and copies it over
 *    the existing graph.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_DESERIALIZE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph deserialize serial
     *             [0]   [1]   [2]
     *
     * SV   = { NODE ATTR/node ARCS ... ATTR/graph }
     *
     * using:
     *            ATTR/x = { key value ... }
     *            ARCS   = { { NAME targetNODEref ATTR/arc } ... }
     */

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

    return g_deserialize (g, interp, objv [2]);
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_DESTROY --
 *
 *    Destroys the whole graph object.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    Releases memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_DESTROY (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph destroy
     *             [0]   [1]
     */

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

    Tcl_DeleteCommandFromToken(interp, g->cmd);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_GET --
 *
 *    Returns the value of the named attribute in the graph.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_GET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph get key
     *             [0]   [1] [2]
     */

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

    return g_attr_get (g->attr, interp, objv[2],
                   objv [0], "\" for graph \"");
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_GETALL --
 *
 *    Returns a dictionary containing all attributes and their values of
 *    the graph.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_GETALL (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph getall ?pattern?
     *             [0]   [1]    [2]
     */

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

    g_attr_getall (g->attr, interp, objc-2, objv+2);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_KEYEXISTS --
 *
 *    Returns a boolean value signaling whether the graph has the
 *    named attribute or not. True implies that the attribute exists.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_KEYEXISTS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph keyexists key
     *             [0]  [1]          [2]
     */

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

    g_attr_kexists (g->attr, interp, objv[2]);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_KEYS --
 *
 *    Returns a list containing all attribute names matching the pattern
 *    for the attributes of the graph.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_KEYS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph keys ?pattern?
     *             [0]  [1]     [2]
     */

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

    g_attr_keys (g->attr, interp, objc-2, objv+2);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_LAPPEND --
 *
 *    Appends a value as list element to an attribute of the graph.
 *    May create the attribute.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_LAPPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph lappend key value
     *             [0]  [1]        [2] [3]
     */

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

    g_attr_extend (&g->attr);
    g_attr_lappend (g->attr, interp, objv[2], objv[3]);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_NODES --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_NODES (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* nwa = nodes with arc, st = starting, en = ending
     *
     * Syntax: graph nodes                       | all nodes
     *         graph nodes -in        NODE...    | nwa en    in node in list
     *         graph nodes -out       NODE...    | nwa st    in node in list
     *         graph nodes -adj       NODE...    | nwa st|en in node in list
     *         graph nodes -inner     NODE...    | nwa st&en in node in list
     *         graph nodes -embedding NODE...    | nwa st^en in node in list
     *         graph nodes -key       KEY        | nodes have attribute KEY
     *         graph nodes -value     VALUE      | nodes have KEY and VALUE
     *         graph nodes -filter    CMDPREFIX  | nodes for which CMD returns True.
     *             [0]   [1]   [2]        [3]
     *
     * -in/-out/-adj/-inner/-embedding are exclusive.
     * -value requires -key.
     * Each option can be used at most once.
     */

    return gc_filter (1, interp, objc, objv, &g->nodes,
                  (GN_GET_GC*) gn_get_node, g);
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_node_APPEND --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_node_APPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph node append NODE KEY VALUE
     *             [0]   [1]  [2]    [3]  [4] [5]
     */

    GN* n;

    if (objc != 6) {
      Tcl_WrongNumArgs (interp, 3, objv, "node key value");
      return TCL_ERROR;
    }

    n = gn_get_node (g, objv [3], interp, objv [0]);
    FAIL (n);

    g_attr_extend (&n->base.attr);
    g_attr_append  (n->base.attr, interp, objv[4], objv[5]);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_node_ATTR --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_node_ATTR (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph node attr KEY
     *         graph node attr KEY -nodes   LIST
     *         graph node attr KEY -glob   PATTERN
     *         graph node attr KEY -regexp PATTERN
     *             [0]   [1]  [2]  [3] [4]     [5]
     */

    static const char* types [] = {
      "-glob", "-nodes", "-regexp", NULL
    };
    int modes [] = {
      A_GLOB, A_LIST, A_REGEXP
    };

    int      mode;
    Tcl_Obj* detail;

    if ((objc != 4) && (objc != 6)) {
      Tcl_WrongNumArgs (interp, 3, objv,
                    "key ?-nodes list|-glob pattern|-regexp pattern?");
      return TCL_ERROR;
    }

    if (objc != 6) {
      detail = NULL;
      mode   = A_NONE;
    } else {
      detail = objv [5];
      if (Tcl_GetIndexFromObj (interp, objv [4], types, "type",
                         0, &mode) != TCL_OK) {
          return TCL_ERROR;
      }
      mode = modes [mode];
    }

    return gc_attr (&g->nodes, mode, detail, interp, objv[3],
                (GN_GET_GC*) gn_get_node, g);
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_node_DEGREE --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_node_DEGREE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph node degree -in|-out NODE
     *             [0]   [1]  [2]    [3]      [4]
     *
     *         graph node degree NODE
     *             [0]   [1]  [2]    [3]
     */

    GN*      n;
    int      dmode;
    int      degree;
    Tcl_Obj* node;

    static const char* dmode_s [] = {
      "-in", "-out", NULL
    };
    enum dmode_e {
      D_IN, D_OUT, D_ALL
    };

    if ((objc != 4) && (objc != 5)) {
      Tcl_WrongNumArgs (interp, 3, objv, "?-in|-out? node");
      return TCL_ERROR;
    }

    if (objc == 5) {
      if (Tcl_GetIndexFromObj (interp, objv [3], dmode_s,
                         "option", 0, &dmode) != TCL_OK) {
          return TCL_ERROR;
      }

      node  = objv [4];
    } else {
      dmode = D_ALL;
      node  = objv [3];
    }

    n = gn_get_node (g, node, interp, objv [0]);
    FAIL (n);

    switch (dmode) {
    case D_IN:  degree = n->in.n;            break;
    case D_OUT: degree = n->out.n;           break;
    case D_ALL: degree = n->in.n + n->out.n; break;
    }

    Tcl_SetObjResult (interp, Tcl_NewIntObj (degree));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_node_DELETE --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_node_DELETE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph node delete NODE NODE...
     *             [0]   [1]  [2]    [3]  [4+]
     */

    int i;
    GN* n;

    if (objc < 4) {
      Tcl_WrongNumArgs (interp, 3, objv, "node node...");
      return TCL_ERROR;
    }

    for (i=3; i< objc; i++) {
      n = gn_get_node (g, objv [i], interp, objv [0]);
      FAIL (n);
    }

    for (i=3; i< objc; i++) {
      n = gn_get_node (g, objv [i], interp, objv [0]);
      gn_delete (n);
    }
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_node_EXISTS --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_node_EXISTS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph node exists NAME
     *             [0]   [1]  [2]    [3]
     */

    GN* n;

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

    n = gn_get_node (g, objv [3], NULL, NULL);

    Tcl_SetObjResult (interp, Tcl_NewIntObj (n != NULL));
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_node_GET --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_node_GET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph node get ARC KEY
     *             [0]   [1]  [2] [3] [4]
     */

    GN* n;

    if (objc != 5) {
      Tcl_WrongNumArgs (interp, 3, objv, "node key");
      return TCL_ERROR;
    }

    n = gn_get_node (g, objv [3], interp, objv [0]);
    FAIL (n);

    return g_attr_get (n->base.attr, interp, objv[4],
                   objv [3], "\" for node \"");
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_node_GETALL --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_node_GETALL (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph arc getall ARC ?PATTERN?
     *             [0]   [1] [2]    [3] [4]
     */

    GN* n;

    if ((objc != 4) && (objc != 5)) {
      Tcl_WrongNumArgs (interp, 3, objv, "node ?pattern?");
      return TCL_ERROR;
    }

    n = gn_get_node (g, objv [3], interp, objv [0]);
    FAIL (n);

    g_attr_getall (n->base.attr, interp, objc-4, objv+4);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_node_INSERT --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_node_INSERT (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph node insert ?NODE...?
     *             [0]   [1]  [2]    [3]
     */

    GN* n;

    if (objc < 3) {
      Tcl_WrongNumArgs (interp, 3, objv, "?node...?");
      return TCL_ERROR;
    }

    if (objc >= 4) {
      int       lc, i;
      Tcl_Obj** lv;

      /* Explicit node names, must not exist */

      for (i=3; i<objc; i++) {
          if (gn_get_node (g, objv [i], NULL, NULL)) {
            gn_err_duplicate (interp, objv[i], objv[0]);
            return TCL_ERROR;
          }
      }

      /* No matching nodes found. Create nodes with specified name, then
       * insert them
       */

      lc = objc-3;
      lv = NALLOC (lc, Tcl_Obj*);

      for (i=3; i<objc; i++) {
          n = gn_new (g, Tcl_GetString (objv [i]));
          lv [i-3] = n->base.name;
      }

      Tcl_SetObjResult (interp, Tcl_NewListObj (lc, lv));
      ckfree ((char*) lv);

    } else {
      /* Create a single new node with a generated name, then insert it. */

      n = gn_new (g, g_newnodename (g));
      Tcl_SetObjResult (interp, Tcl_NewListObj (1, &n->base.name));
    }

    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_node_KEYEXISTS --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_node_KEYEXISTS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph node keyexists ARC KEY
     *             [0]   [1]  [2]       [3] [4]
     */

    GN* n;

    if (objc != 5) {
      Tcl_WrongNumArgs (interp, 3, objv, "node key");
      return TCL_ERROR;
    }

    n = gn_get_node (g, objv [3], interp, objv [0]);
    FAIL (n);

    g_attr_kexists (n->base.attr, interp, objv[4]);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_node_KEYS --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_node_KEYS (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph node keys NODE ?PATTERN?
     *             [0]  [1]     [2]  [3]  [4]
     */

    GN* n;

    if ((objc != 4) && (objc != 5)) {
      Tcl_WrongNumArgs (interp, 3, objv, "node ?pattern?");
      return TCL_ERROR;
    }

    n = gn_get_node (g, objv [3], interp, objv [0]);
    FAIL (n);

    g_attr_keys (n->base.attr, interp, objc-4, objv+4);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_node_LAPPEND --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_node_LAPPEND (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph node lappend NODE KEY VALUE
     *             [0]   [1]  [2]     [3]  [4] [5]
     */

    GN* n;

    if (objc != 6) {
      Tcl_WrongNumArgs (interp, 3, objv, "node key value");
      return TCL_ERROR;
    }

    n = gn_get_node (g, objv [3], interp, objv [0]);
    FAIL (n);

    g_attr_extend (&n->base.attr);
    g_attr_lappend (n->base.attr, interp, objv[4], objv[5]);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_node_OPPOSITE --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_node_OPPOSITE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph node opposite NODE ARC
     *             [0]   [1]  [2]      [3]  [4]
     */

    GN* n;
    GA* a;

    if (objc != 5) {
      Tcl_WrongNumArgs (interp, 3, objv, "node arc");
      return TCL_ERROR;
    }

    n = gn_get_node (g, objv [3], interp, objv [0]);
    FAIL (n);

    a = ga_get_arc (g, objv [4], interp, objv [0]);
    FAIL (a);

    if (a->start->n == n) {
      Tcl_SetObjResult (interp, a->end->n->base.name);
    } else if (a->end->n == n) {
      Tcl_SetObjResult (interp, a->start->n->base.name);
    } else {
      Tcl_Obj* err = Tcl_NewObj ();

      Tcl_AppendToObj      (err, "node \"", -1);
      Tcl_AppendObjToObj (err, n->base.name);
      Tcl_AppendToObj      (err, "\" and arc \"", -1);
      Tcl_AppendObjToObj (err, a->base.name);
      Tcl_AppendToObj      (err, "\" are not connected in graph \"", -1);
      Tcl_AppendObjToObj (err, objv [0]);
      Tcl_AppendToObj      (err, "\"", -1);

      Tcl_SetObjResult (interp, err);
      return TCL_ERROR;
    }

    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_node_RENAME --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_node_RENAME (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph node rename NODE NEW
     *             [0]   [1]  [2]    [3]  [4]
     */

    GC* c;

    if (objc != 5) {
      Tcl_WrongNumArgs (interp, 3, objv, "node newname");
      return TCL_ERROR;
    }

    c = (GC*) gn_get_node (g, objv [3], interp, objv [0]);
    FAIL (c);

    if (gn_get_node (g, objv [4], NULL, NULL)) {
      gn_err_duplicate (interp, objv[4], objv[0]);
      return TCL_ERROR;
    }

    gc_rename (c, &g->nodes, objv[4], interp);
    gn_shimmer_self ((GN*) c);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_node_SET --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_node_SET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph node set NODE KEY ?VALUE?
     *             [0]   [1]  [2] [3]  [4] [5]
     */

    GC* c;

    if ((objc != 5) && (objc != 6)) {
      Tcl_WrongNumArgs (interp, 3, objv, "node key ?value?");
      return TCL_ERROR;
    }

    c = (GC*) gn_get_node (g, objv [3], interp, objv [0]);
    FAIL (c);

    if (objc == 5) {
      return g_attr_get (c->attr, interp, objv[4],
                     objv [3], "\" for node \"");
    } else {
      g_attr_extend (&c->attr);
      g_attr_set     (c->attr, interp, objv[4], objv[5]);
      return TCL_OK;
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_node_UNSET --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_node_UNSET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph node unset NODE KEY
     *             [0]   [1]  [2]   [3]  [4]
     */

    GC* c;

    if (objc != 5) {
      Tcl_WrongNumArgs (interp, 3, objv, "node key");
      return TCL_ERROR;
    }

    c = (GC*) gn_get_node (g, objv [3], interp, objv [0]);
    FAIL (c);

    g_attr_unset (c->attr, objv [4]);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_SERIALIZE --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_SERIALIZE (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph serialize NODE...
     *             [0]   [1]       [2]
     *
     * SV   = { NODE ATTR/node ARCS ... ATTR/graph }
     *
     * using:
     *            ATTR/x = { key value ... }
     *            ARCS   = { { NAME targetNODEref ATTR/arc } ... }
     */

    Tcl_Obj* sv = g_ms_serialize (interp, objv[0], g, objc-2, objv+2);

    if (!sv) {
      return TCL_ERROR;
    }
    Tcl_SetObjResult (interp, sv);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_SET --
 *
 *    Adds an attribute and its value to the graph. May replace an
 *    existing value.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_SET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph set key ?value?
     *             [0]  [1]  [2] [3]
     */

    if ((objc != 3) && (objc != 4)) {
      Tcl_WrongNumArgs (interp, 2, objv, "key ?value?");
      return TCL_ERROR;
    }

    if (objc == 3) {
      return g_attr_get (g->attr, interp, objv[2],
                     objv [0], "\" for graph \"");
    } else {
      g_attr_extend (&g->attr);
      g_attr_set     (g->attr, interp, objv[2], objv[3]);
      return TCL_OK;
    }
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_SWAP --
 *
 *    Swap the names of two nodes.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *      None.
 *
 *---------------------------------------------------------------------------
 */

int
gm_SWAP (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph swap a   b
     *             [0]  [1]     [2] [3]
     */

    GN*             na;
    GN*             nb;
    const char*   key;

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

    na = gn_get_node (g, objv [2], interp, objv [0]);
    FAIL (na);

    nb = gn_get_node (g, objv [3], interp, objv [0]);
    FAIL (nb);

    if (na == nb) {
      Tcl_Obj* err = Tcl_NewObj ();

      Tcl_AppendToObj      (err, "cannot swap node \"", -1);
      Tcl_AppendObjToObj (err, objv [2]);
      Tcl_AppendToObj      (err, "\" with itself", -1);

      Tcl_SetObjResult (interp, err);
      return TCL_ERROR;
    }

    {
#define SWAP(a,b,t) t = a; a = b ; b = t
#define SWAPS(x,t) SWAP(na->x,nb->x,t)

      /* The two nodes flip all structural information around to trade places */
      /* It might actually be easier to flip the non-structural data */
      /* name, he, attr, data in the node map */

      Tcl_Obj*       to;
      Tcl_HashTable* ta;
      Tcl_HashEntry* th;

      SWAPS (base.name, to);
      SWAPS (base.attr, ta);
      SWAPS (base.he,   th);

      Tcl_SetHashValue (na->base.he, (ClientData) na);
      Tcl_SetHashValue (nb->base.he, (ClientData) nb);
    }

    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_UNSET --
 *
 *    Removes an attribute and its value from the graph.
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_UNSET (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph unset key
     *             [0]  [1]      [2]
     */

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

    g_attr_unset (g->attr, objv [2]);
    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * gm_WALK --
 *
 *      
 *    
 *
 * Results:
 *    A standard Tcl result code.
 *
 * Side effects:
 *    May release and allocate memory.
 *
 *---------------------------------------------------------------------------
 */

int
gm_WALK (G* g, Tcl_Interp* interp, int objc, Tcl_Obj* const* objv)
{
    /* Syntax: graph walk NODE ?-type TYPE? ?-order ORDER? ?-dir DIR? -command CMD
     *             [0]   [1]  [2]  [3]    [4]   [5]     [6]    [7]   [8]  [9]      [10]
     *
     * TYPE  bfs|dfs
     * ORDER pre|post|both
     * DIR   backward|forward
     *
     * bfs => !post && !both
     */

    int       cc, type, order, dir;
    Tcl_Obj** cv;
    GN*       n;

    if (objc < 5) {
      Tcl_WrongNumArgs (interp, 2, objv, W_USAGE);
      return TCL_ERROR;
    }

    n = gn_get_node (g, objv [2], interp, objv [0]);
    FAIL(n);

    if (g_walkoptions (interp, objc, objv,
                   &type, &order, &dir,
                   &cc, &cv) != TCL_OK) {
      return TCL_ERROR;
    }

    return g_walk (interp, objv[0], n, type, order, dir, cc, cv);
}


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

/*
 * Handling of all indices, numeric and 'end-x' forms.  Copied straight out of
 * the Tcl core as this is not exported through the public API.
 *
 * I.e. a full copy of TclGetIntForIndex, its Tcl_ObjType, and of several
 * supporting functions and macros internal to the core.  :(
 *
 * To avoid clashing with the object type in the core the object type here has
 * been given a different name.
 */

#define UCHAR(c) ((unsigned char) (c))

static void UpdateStringOfEndOffset _ANSI_ARGS_((Tcl_Obj* objPtr));
static int SetEndOffsetFromAny _ANSI_ARGS_((Tcl_Interp* interp,
                                  Tcl_Obj* objPtr));

static int TclCheckBadOctal (Tcl_Interp *interp, const char *value);
static int TclFormatInt     (char *buffer, long n);


Tcl_ObjType EndOffsetTypeGraph = {
    "tcllib/struct::graph/end-offset",    /* name */
    (Tcl_FreeInternalRepProc*) NULL,      /* freeIntRepProc */
    (Tcl_DupInternalRepProc*) NULL, /* dupIntRepProc */
    UpdateStringOfEndOffset,        /* updateStringProc */
    SetEndOffsetFromAny
};

static int
TclGetIntForIndex (Tcl_Interp* interp, Tcl_Obj* objPtr, int endValue, int* indexPtr)
{
    if (Tcl_GetIntFromObj (NULL, objPtr, indexPtr) == TCL_OK) {
      return TCL_OK;
    }

    if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) {
      /*
       * If the object is already an offset from the end of the
       * list, or can be converted to one, use it.
       */

      *indexPtr = endValue + objPtr->internalRep.longValue;

    } else {
      /*
       * Report a parse error.
       */

      if (interp != NULL) {
          char *bytes = Tcl_GetString(objPtr);
          /*
           * The result might not be empty; this resets it which
           * should be both a cheap operation, and of little problem
           * because this is an error-generation path anyway.
           */
          Tcl_ResetResult(interp);
          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                           "bad index \"", bytes,
                           "\": must be integer or end?-integer?",
                           (char *) NULL);
          if (!strncmp(bytes, "end-", 3)) {
            bytes += 3;
          }
          TclCheckBadOctal(interp, bytes);
      }

      return TCL_ERROR;
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * UpdateStringOfEndOffset --
 *
 *    Update the string rep of a Tcl object holding an "end-offset"
 *    expression.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    Stores a valid string in the object's string rep.
 *
 * This procedure does NOT free any earlier string rep.      If it is
 * called on an object that already has a valid string rep, it will
 * leak memory.
 *
 *----------------------------------------------------------------------
 */

static void
UpdateStringOfEndOffset(objPtr)
     register Tcl_Obj* objPtr;
{
    char buffer[TCL_INTEGER_SPACE + sizeof("end") + 1];
    register int len;

    strcpy(buffer, "end");
    len = sizeof("end") - 1;
    if (objPtr->internalRep.longValue != 0) {
      buffer[len++] = '-';
      len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue));
    }
    objPtr->bytes = ckalloc((unsigned) (len+1));
    strcpy(objPtr->bytes, buffer);
    objPtr->length = len;
}

/*
 *----------------------------------------------------------------------
 *
 * SetEndOffsetFromAny --
 *
 *    Look for a string of the form "end-offset" and convert it
 *    to an internal representation holding the offset.
 *
 * Results:
 *    Returns TCL_OK if ok, TCL_ERROR if the string was badly formed.
 *
 * Side effects:
 *    If interp is not NULL, stores an error message in the
 *    interpreter result.
 *
 *----------------------------------------------------------------------
 */

static int
SetEndOffsetFromAny(interp, objPtr)
     Tcl_Interp* interp;      /* Tcl interpreter or NULL */
     Tcl_Obj* objPtr;         /* Pointer to the object to parse */
{
    int offset;               /* Offset in the "end-offset" expression */
    Tcl_ObjType* oldTypePtr = objPtr->typePtr;
    /* Old internal rep type of the object */
    register char* bytes;     /* String rep of the object */
    int length;               /* Length of the object's string rep */

    /* If it's already the right type, we're fine. */

    if (objPtr->typePtr == &EndOffsetTypeGraph) {
      return TCL_OK;
    }

    /* Check for a string rep of the right form. */

    bytes = Tcl_GetStringFromObj(objPtr, &length);
    if ((*bytes != 'e') || (strncmp(bytes, "end",
                            (size_t)((length > 3) ? 3 : length)) != 0)) {
      if (interp != NULL) {
          Tcl_ResetResult(interp);
          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                           "bad index \"", bytes,
                           "\": must be end?-integer?",
                           (char*) NULL);
      }
      return TCL_ERROR;
    }

    /* Convert the string rep */

    if (length <= 3) {
      offset = 0;
    } else if ((length > 4) && (bytes[3] == '-')) {
      /*
       * This is our limited string expression evaluator.  Pass everything
       * after "end-" to Tcl_GetInt, then reverse for offset.
       */
      if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) {
          return TCL_ERROR;
      }
      offset = -offset;
    } else {
      /*
       * Conversion failed.  Report the error.
       */
      if (interp != NULL) {
          Tcl_ResetResult(interp);
          Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
                           "bad index \"", bytes,
                           "\": must be integer or end?-integer?",
                           (char *) NULL);
      }
      return TCL_ERROR;
    }

    /*
     * The conversion succeeded. Free the old internal rep and set
     * the new one.
     */

    if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
      oldTypePtr->freeIntRepProc(objPtr);
    }

    objPtr->internalRep.longValue = offset;
    objPtr->typePtr = &EndOffsetTypeGraph;

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * TclCheckBadOctal --
 *
 *    This procedure checks for a bad octal value and appends a
 *    meaningful error to the interp's result.
 *
 * Results:
 *    1 if the argument was a bad octal, else 0.
 *
 * Side effects:
 *    The interpreter's result is modified.
 *
 *----------------------------------------------------------------------
 */

static int
TclCheckBadOctal(interp, value)
     Tcl_Interp *interp;            /* Interpreter to use for error reporting.
                         * If NULL, then no error message is left
                         * after errors. */
     const char *value;       /* String to check. */
{
    register const char *p = value;

    /*
     * A frequent mistake is invalid octal values due to an unwanted
     * leading zero. Try to generate a meaningful error message.
     */

    while (isspace(UCHAR(*p))) {    /* INTL: ISO space. */
      p++;
    }
    if (*p == '+' || *p == '-') {
      p++;
    }
    if (*p == '0') {
      while (isdigit(UCHAR(*p))) {  /* INTL: digit. */
          p++;
      }
      while (isspace(UCHAR(*p))) {  /* INTL: ISO space. */
          p++;
      }
      if (*p == '\0') {
          /* Reached end of string */
          if (interp != NULL) {
            /*
             * Don't reset the result here because we want this result
             * to be added to an existing error message as extra info.
             */
            Tcl_AppendResult(interp, " (looks like invalid octal number)",
                         (char *) NULL);
          }
          return 1;
      }
    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclFormatInt --
 *
 *    This procedure formats an integer into a sequence of decimal digit
 *    characters in a buffer. If the integer is negative, a minus sign is
 *    inserted at the start of the buffer. A null character is inserted at
 *    the end of the formatted characters. It is the caller's
 *    responsibility to ensure that enough storage is available. This
 *    procedure has the effect of sprintf(buffer, "%d", n) but is faster.
 *
 * Results:
 *    An integer representing the number of characters formatted, not
 *    including the terminating \0.
 *
 * Side effects:
 *    The formatted characters are written into the storage pointer to
 *    by the "buffer" argument.
 *
 *----------------------------------------------------------------------
 */

static int
TclFormatInt(buffer, n)
     char *buffer;            /* Points to the storage into which the
                         * formatted characters are written. */
     long n;                  /* The integer to format. */
{
    long intVal;
    int i;
    int numFormatted, j;
    char *digits = "0123456789";

    /*
     * Check first whether "n" is zero.
     */

    if (n == 0) {
      buffer[0] = '0';
      buffer[1] = 0;
      return 1;
    }

    /*
     * Check whether "n" is the maximum negative value. This is
     * -2^(m-1) for an m-bit word, and has no positive equivalent;
     * negating it produces the same value.
     */

    if (n == -n) {
      sprintf(buffer, "%ld", n);
      return strlen(buffer);
    }

    /*
     * Generate the characters of the result backwards in the buffer.
     */

    intVal = (n < 0? -n : n);
    i = 0;
    buffer[0] = '\0';
    do {
      i++;
      buffer[i] = digits[intVal % 10];
      intVal = intVal/10;
    } while (intVal > 0);
    if (n < 0) {
      i++;
      buffer[i] = '-';
    }
    numFormatted = i;

    /*
     * Now reverse the characters.
     */

    for (j = 0;    j < i;      j++, i--) {
      char tmp = buffer[i];
      buffer[i] = buffer[j];
      buffer[j] = tmp;
    }
    return numFormatted;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Generated by  Doxygen 1.6.0   Back to index