tree: support for duplicate keys.

* tree.c (tr_insert): New argument for allowing duplicate.
If it is true, suppresses the case of replacing a node,
causing the logic to fall through to traversing right, so the
duplicate key effectively looks like it is greater than the
existing duplicates, and gets inserted as the rightmost
duplicate.
(tr_do_delete_specific, tr_delete_specific): New static functions.
(tree_insert_node): New parameter, passed to tr_insert.
(tree_insert): New parameter, passed to tree_insert_node.
(tree_delete_specific_node): New function.
(tree): New parameter to allow duplicate keys in the elements
sequence.
(tree_construct): Pass t to tree to allow duplicate elements.
(tree_init): Update registrations of tree, tree-insert and
tree-insert-node. Register tree-delete-specific-node function.

* tree.h (tree, tree_insert_node, tree_insert): Declarations
updated.
(tree_delete_specific_node): Declared.

* lib.c (seq): Pass t argument to tree_insert, allowing
duplicates.

* parser.c (circ_backpatch): Likewise.

* parser.y (tree): Pass t to new argument of tree, so
duplicates are preserved in the element list of the #T
literal.

* y.tab.c.shipped: Updated.

* tests/010/tree.tl: Test cases for duplicate keys.

* txr.1: Documented.

* stdlib/doc-syms.tl: Updated.

9 files changed, 309 insertions, 28 deletions

diff --git a/lib.c b/lib.c
index 1bcd9ffc..36b6186d 100644
--- a/lib.c
+++ b/lib.c
@@ -12814,7 +12814,7 @@ val sel(val seq, val where_in)
       while (seq_get(&wh_iter, &wh)) {
         val node = tree_lookup_node(seq, wh);
         if (node)
-          tree_insert(newtree, key(node));
+          tree_insert(newtree, key(node), t);
       }
 
       return newtree;
diff --git a/parser.c b/parser.c
index 060643b4..bca07741 100644
--- a/parser.c
+++ b/parser.c
@@ -444,7 +444,7 @@ tail:
 
         while (nodes) {
           val node = rcyc_pop(&nodes);
-          tree_insert_node(obj, node);
+          tree_insert_node(obj, node, t);
         }
       } else {
         while (nodes)
diff --git a/parser.y b/parser.y
index 7b09fd7b..4fe33092 100644
--- a/parser.y
+++ b/parser.y
@@ -956,7 +956,7 @@ tree : HASH_T list             { if (parser->ignore)
                                    val less_fn = fname_helper(parser, less_fn_name);
                                    val equal_fn = fname_helper(parser, equal_fn_name);
                                    val tr = tree(rest($2), key_fn,
-                                                 less_fn, equal_fn);
+                                                 less_fn, equal_fn, t);
                                      $$ = rl(tr, num($1)); } }
      | HASH_T error            { $$ = nil;
                                  yybadtok(yychar, lit("tree node literal")); }
diff --git a/stdlib/doc-syms.tl b/stdlib/doc-syms.tl
index 654a3610..80922b42 100644
--- a/stdlib/doc-syms.tl
+++ b/stdlib/doc-syms.tl
@@ -2002,8 +2002,10 @@
       ("tree-bind" "N-021A9008")
       ("tree-case" "N-03D834A5")
       ("tree-clear" "N-03C88274")
+      ("tree-count" "N-032882F2")
       ("tree-delete" "N-022035DF")
       ("tree-delete-node" "N-00772FAE")
+      ("tree-delete-specific-node" "N-009B02CA")
       ("tree-find" "N-0149BC05")
       ("tree-insert" "N-0114FF9E")
       ("tree-insert-node" "N-008B4AD9")
diff --git a/tests/010/tree.tl b/tests/010/tree.tl
index f5bfac42..898fd91d 100644
--- a/tests/010/tree.tl
+++ b/tests/010/tree.tl
@@ -183,3 +183,36 @@
   (uni #T(() "a" "b") #T(() "b" "c")) ("a" "b" "c")
   (diff #T(() "a" "b") #T(() "b" "c")) ("a")
   (isec #T(() "a" "b") #T(() "b" "c")) ("b"))
+
+(defstruct (item label key) ()
+  label
+  key
+  (:method equal (it) it.key))
+
+(defun make-items ()
+  (vec (new (item 'a 1))
+       (new (item 'b 2))
+       (new (item 'c 2))
+       (new (item 'd 2))
+       (new (item 'e 2))
+       (new (item 'f 3))))
+
+(let* ((items (make-items))
+       (tr (tree items : : : t)))
+  (each ((it items))
+    (vtest (tree-delete tr it) it))
+  (test tr #T(())))
+
+(let* ((items (make-items))
+       (tr (tree items : : : t)))
+  (each ((it items))
+    (let* ((tn (tree-lookup-node tr it.key))
+           (iu (key tn)))
+      (vtest (tree-delete-specific-node tr tn) tn)
+      (each ((iv tr))
+        (test (eq iv.label iu.label) nil))))
+  (test tr #T(())))
+
+(let* ((items (make-items))
+       (tr (tree items : : : t)))
+  (vtest (vec-list [mapcar .label tr]) [mapcar .label items]))
diff --git a/tree.c b/tree.c
index 6adcdd7d..c3ddd756 100644
--- a/tree.c
+++ b/tree.c
@@ -360,7 +360,7 @@ static void tr_find_rebuild_scapegoat(val tree, struct tree *tr,
 }
 
 static void tr_insert(val tree, struct tree *tr, struct tree_iter *ti,
-                      val subtree, val node)
+                      val subtree, val node, val dup)
 {
   val tn_key = if3(tr->key_fn,
                    funcall1(tr->key_fn, node->tn.key),
@@ -375,7 +375,7 @@ static void tr_insert(val tree, struct tree *tr, struct tree_iter *ti,
   {
     if (subtree->tn.left) {
       set(mkloc(ti->path[ti->depth++], ti->self), subtree);
-      tr_insert(tree, tr, ti, subtree->tn.left, node);
+      tr_insert(tree, tr, ti, subtree->tn.left, node, dup);
     } else {
       int dep = ti->depth + 1;
       set(mkloc(subtree->tn.left, subtree), node);
@@ -386,7 +386,9 @@ static void tr_insert(val tree, struct tree *tr, struct tree_iter *ti,
     }
   } else if (if3(tr->equal_fn == nil,
                  equal(tn_key, tr_key),
-                 funcall2(tr->equal_fn, tn_key, tr_key))) {
+                 funcall2(tr->equal_fn, tn_key, tr_key)) &&
+             !dup)
+  {
     set(mkloc(node->tn.left, node), subtree->tn.left);
     set(mkloc(node->tn.right, node), subtree->tn.right);
     if (ti->depth > 0) {
@@ -402,7 +404,7 @@ static void tr_insert(val tree, struct tree *tr, struct tree_iter *ti,
   } else {
     if (subtree->tn.right) {
       set(mkloc(ti->path[ti->depth++], ti->self), subtree);
-      tr_insert(tree, tr, ti, subtree->tn.right, node);
+      tr_insert(tree, tr, ti, subtree->tn.right, node, dup);
     } else {
       int dep = ti->depth + 1;
       set(mkloc(subtree->tn.right, subtree), node);
@@ -483,6 +485,79 @@ static val tr_do_delete(val tree, struct tree *tr, val subtree,
   }
 }
 
+static val tr_do_delete_specific(val tree, struct tree *tr, val subtree,
+                                 val parent, val key, val thisnode)
+{
+  if (subtree == nil) {
+    return nil;
+  } else if (subtree == thisnode) {
+    val le = subtree->tn.left;
+    val ri = subtree->tn.right;
+
+    if (le && ri) {
+      struct tree_iter trit = tree_iter_init(0);
+      val succ = tn_find_next(ri, &trit);
+      val succ_par = if3(trit.depth, trit.path[trit.depth - 1], subtree);
+
+      if (succ_par == subtree)
+        set(mkloc(succ_par->tn.right, succ_par), succ->tn.right);
+      else
+        set(mkloc(succ_par->tn.left, succ_par), succ->tn.right);
+
+      set(mkloc(succ->tn.left, succ), subtree->tn.left);
+      set(mkloc(succ->tn.right, succ), subtree->tn.right);
+
+      if (parent) {
+        if (parent->tn.left == subtree)
+          set(mkloc(parent->tn.left, parent), succ);
+        else
+          set(mkloc(parent->tn.right, parent), succ);
+      } else {
+        tr->root = succ;
+      }
+    } else {
+      uses_or2;
+      val chld = or2(le, ri);
+
+      if (parent) {
+        if (parent->tn.left == subtree)
+          set(mkloc(parent->tn.left, parent), chld);
+        else
+          set(mkloc(parent->tn.right, parent), chld);
+      } else {
+        set(mkloc(tr->root, tree), chld);
+      }
+    }
+
+    subtree->tn.left = subtree->tn.right = nil;
+    return subtree;
+  }
+
+  val tr_key = if3(tr->key_fn,
+                   funcall1(tr->key_fn, subtree->tn.key),
+                   subtree->tn.key);
+
+  if (if3(tr->less_fn,
+          funcall2(tr->less_fn, key, tr_key),
+          less(key, tr_key)))
+  {
+    val le = subtree->tn.left;
+    return tr_do_delete_specific(tree, tr, le, subtree, key, thisnode);
+  } else if (if3(tr->equal_fn == nil,
+                 equal(key, tr_key),
+                 funcall2(tr->equal_fn, key, tr_key)))
+  {
+    uses_or2;
+    val le = subtree->tn.left;
+    val ri = subtree->tn.right;
+    return or2(tr_do_delete_specific(tree, tr, le, subtree, key, thisnode),
+               tr_do_delete_specific(tree, tr, ri, subtree, key, thisnode));
+  } else {
+    val ri = subtree->tn.right;
+    return tr_do_delete_specific(tree, tr, ri, subtree, key, thisnode);
+  }
+}
+
 static val tr_delete(val tree, struct tree *tr, val key)
 {
   if (tr->root) {
@@ -499,10 +574,28 @@ static val tr_delete(val tree, struct tree *tr, val key)
   return nil;
 }
 
-val tree_insert_node(val tree, val node)
+static val tr_delete_specific(val tree, struct tree *tr, val thisnode)
+{
+  if (tr->root) {
+    val node = tr_do_delete_specific(tree, tr, tr->root,
+                                     nil, key(thisnode), thisnode);
+    if (node) {
+      if (2 * --tr->size < tr->max_size) {
+        tr_rebuild(tree, tr, tr->root, nil, tr->size);
+        tr->max_size = tr->size;
+      }
+    }
+    return node;
+  }
+
+  return nil;
+}
+
+val tree_insert_node(val tree, val node, val dup_in)
 {
   val self = lit("tree-insert-node");
   struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_cls));
+  val dup = default_null_arg(dup_in);
 
   type_check(self, node, TNOD);
 
@@ -517,15 +610,15 @@ val tree_insert_node(val tree, val node)
     struct tree_iter ti = tree_iter_init(0);
     if (++tr->size > tr->max_size)
       tr->max_size = tr->size;
-    tr_insert(tree, tr, &ti, tr->root, node);
+    tr_insert(tree, tr, &ti, tr->root, node, dup);
   }
 
   return node;
 }
 
-val tree_insert(val tree, val key)
+val tree_insert(val tree, val key, val dup_in)
 {
-  return tree_insert_node(tree, tnode(key, nil, nil));
+  return tree_insert_node(tree, tnode(key, nil, nil), default_null_arg(dup_in));
 }
 
 val tree_lookup_node(val tree, val key)
@@ -554,6 +647,14 @@ val tree_delete(val tree, val key)
   return if2(node, node->tn.key);
 }
 
+val tree_delete_specific_node(val tree, val node)
+{
+  val self = lit("tree-delete-node");
+  struct tree *tr = coerce(struct tree *, cobj_handle(self, tree, tree_cls));
+  return tr_delete_specific(tree, tr, node);
+}
+
+
 static val tree_root(val tree)
 {
   val self = lit("tree-root");
@@ -680,11 +781,12 @@ static struct cobj_ops tree_ops = cobj_ops_init(tree_equal_op,
                                                 tree_mark,
                                                 tree_hash_op);
 
-val tree(val keys_in, val key_fn, val less_fn, val equal_fn)
+val tree(val keys_in, val key_fn, val less_fn, val equal_fn, val dup_in)
 {
   struct tree *tr = coerce(struct tree *, chk_calloc(1, sizeof *tr));
   val keys = default_null_arg(keys_in), key;
   val tree = cobj(coerce(mem_t *, tr), tree_cls, &tree_ops);
+  val dup = default_null_arg(dup_in);
   seq_iter_t ki;
   uses_or2;
 
@@ -702,7 +804,7 @@ val tree(val keys_in, val key_fn, val less_fn, val equal_fn)
   seq_iter_init(tree_s, &ki, keys);
 
   while (seq_get(&ki, &key))
-    tree_insert(tree, key);
+    tree_insert(tree, key, dup);
 
   return tree;
 }
@@ -728,7 +830,7 @@ static val tree_construct(val opts, val keys)
   val key_fn = tree_construct_fname(pop(&opts));
   val less_fn = tree_construct_fname(pop(&opts));
   val equal_fn = tree_construct_fname(pop(&opts));
-  return tree(keys, key_fn, less_fn, equal_fn);
+  return tree(keys, key_fn, less_fn, equal_fn, t);
 }
 
 static val deep_copy_tnode(val node)
@@ -993,18 +1095,19 @@ void tree_init(void)
   reg_fun(intern(lit("set-key"), user_package), func_n2(set_key));
   reg_fun(intern(lit("copy-tnode"), user_package), func_n1(copy_tnode));
   reg_fun(intern(lit("tnodep"), user_package), func_n1(tnodep));
-  reg_fun(tree_s, func_n4o(tree, 0));
+  reg_fun(tree_s, func_n5o(tree, 0));
   reg_fun(tree_construct_s, func_n2(tree_construct));
   reg_fun(intern(lit("copy-search-tree"), user_package), func_n1(copy_search_tree));
   reg_fun(intern(lit("make-similar-tree"), user_package), func_n1(make_similar_tree));
   reg_fun(intern(lit("treep"), user_package), func_n1(treep));
   reg_fun(intern(lit("tree-count"), user_package), func_n1(tree_count));
-  reg_fun(intern(lit("tree-insert-node"), user_package), func_n2(tree_insert_node));
-  reg_fun(intern(lit("tree-insert"), user_package), func_n2(tree_insert));
+  reg_fun(intern(lit("tree-insert-node"), user_package), func_n3o(tree_insert_node, 2));
+  reg_fun(intern(lit("tree-insert"), user_package), func_n3o(tree_insert, 2));
   reg_fun(intern(lit("tree-lookup-node"), user_package), func_n2(tree_lookup_node));
   reg_fun(intern(lit("tree-lookup"), user_package), func_n2(tree_lookup));
   reg_fun(intern(lit("tree-delete-node"), user_package), func_n2(tree_delete_node));
   reg_fun(intern(lit("tree-delete"), user_package), func_n2(tree_delete));
+  reg_fun(intern(lit("tree-delete-specific-node"), user_package), func_n2(tree_delete_specific_node));
   reg_fun(intern(lit("tree-root"), user_package), func_n1(tree_root));
   reg_fun(intern(lit("tree-begin"), user_package), func_n3o(tree_begin, 1));
   reg_fun(intern(lit("copy-tree-iter"), user_package), func_n1(copy_tree_iter));
diff --git a/tree.h b/tree.h
index b0b85801..ad1b2327 100644
--- a/tree.h
+++ b/tree.h
@@ -40,17 +40,18 @@ val set_left(val node, val nleft);
 val set_right(val node, val nright);
 val set_key(val node, val nkey);
 val copy_tnode(val node);
-val tree(val keys, val key_fn, val less_fn, val equal_fn);
+val tree(val keys, val key_fn, val less_fn, val equal_fn, val dup);
 val copy_search_tree(val tree);
 val make_similar_tree(val tree);
 val treep(val obj);
 val tree_count(val tree);
-val tree_insert_node(val tree, val node);
-val tree_insert(val tree, val key);
+val tree_insert_node(val tree, val node, val dup);
+val tree_insert(val tree, val key, val dup);
 val tree_lookup_node(val tree, val key);
 val tree_lookup(val tree, val key);
 val tree_delete_node(val tree, val key);
 val tree_delete(val tree, val key);
+val tree_delete_specific_node(val tree, val node);
 val tree_begin(val tree, val lowkey, val highkey);
 val copy_tree_iter(val iter);
 val replace_tree_iter(val diter, val siter);
diff --git a/txr.1 b/txr.1
index 990b9522..4c650f0d 100644
--- a/txr.1
+++ b/txr.1
@@ -12498,6 +12498,12 @@ syntax, either explicitly or as defaults. Then, every
 object is constructed from its respective literal syntax and inserted into
 the tree.
 
+Duplicate objects are preserved. For instance the tree literal
+.code "#T(() 1 1 1)"
+specifies a tree with three nodes which have the same key.
+Duplicates appear in the tree in the order that they appear in the
+literal.
+
 .NP* JSON Literals
 .meIP >> #J json-syntax
 Introduces a JSON literal.
@@ -53898,6 +53904,26 @@ objects as arguments or return
 .code tnode
 objects.
 
+Trees may store duplicate elements. The
+.code #T
+literal syntax may freely specify duplicate elements.
+The
+.code tree
+constructor function specifies an initial sequence of elements to
+be populated into the newly constructed tree. If this initial
+sequence contains duplicate elements, they are preserved if the optional
+.meta allow-dupes
+argument is true, otherwise only the rightmost member of any duplicate
+group appears in the tree.
+
+The insertion functions
+.code tree-insert
+and
+.code tree-insert-node
+also overwrite duplicates by default, but optionally allow them.
+Duplicates are ordered by insertion: most recently inserted duplicate
+is rightmost. However, tree lookup chooses an unspecified duplicate.
+
 .coNP Function @ tnode
 .synb
 .mets (tnode < key < left << right )
@@ -54024,7 +54050,8 @@ fields are copied from
 
 .coNP Function @ tree
 .synb
-.mets (tree >> [ elems >> [ keyfun >> [ lessfun <> [ equalfun ]]]])
+.mets (tree >> [ elems
+.mets \ \ \ \ \ \  >> [ keyfun >> [ lessfun >> [ equalfun <> [ allow-dupes ]]]])
 .syne
 .desc
 The
@@ -54069,6 +54096,44 @@ properties of an equivalence relation.
 These three functions are collectively referred to as the tree's
 .IR "key abstraction functions" .
 
+The
+.meta allow-dupes
+argument, which defaults to
+.codn nil ,
+is relevant if an
+.meta elems
+sequence is specified containing some elements which which appear to be
+duplicates, according to the tree object's
+.meta equalfun
+function. If
+.meta allow-dupes
+is true then duplicates are preserved: the tree will have as many nodes as
+there are elements in the
+.meta elems
+sequence. Moreover, the duplicates appear in the same relative order in
+the tree as they appear in the original
+.meta elems
+sequence.
+If
+.meta allow-dupes
+is false, then duplicates are suppressed: if any element appears more
+than once in
+.metn elements ,
+then only the last occurrence of that element appears in the tree.
+
+Note: the
+.code tree-insert
+and
+.code tree-insert-node
+functions also has an optional argument indicating whether an duplicate
+insertion replaces an existing element.
+
+Note: although the order of duplicate elements is preserved, when the
+.code tree-lookup
+function is used look up an key which is duplicated, the element
+which is retrieved is unspecified, and can change when the tree is
+reorganized due to insertions and deletions.
+
 .coNP Function @ treep
 .synb
 .mets (treep << value )
@@ -54097,7 +54162,7 @@ which must be a search tree object.
 
 .coNP Function @ tree-insert-node
 .synb
-.mets (tree-insert-node < tree << node )
+.mets (tree-insert-node < tree < node <> [ allow-dupe ])
 .syne
 .desc
 The
@@ -54140,11 +54205,30 @@ fields of
 are overwritten as required by the semantics of the insertion operation.
 Their original values are ignored.
 
-If
-.meta tree
-already contains node with with a matching key, then
+The
+.meta allow-dupe
+argument, defaulting to
+.codn nil ,
+is concerned with what happens if the tree already contains one or more
+nodes having a key equal to the
+.metn node 's
+key.
+.meta allow-dupe
+is false, then
 .meta node
-replaces that node; that node is deleted from the tree.
+replaces an unspecified one of those existing nodes: that replaced node is
+deleted from the tree. Key equivalence is determined using tree's equality
+function (see the
+.meta equalfun
+argument of the
+.code tree
+function).
+If
+.meta allow-dupe
+is true, then the new node is inserted without replacing any node, and
+appears together with the existing duplicate or duplicates. Among
+the duplicates, the newly inserted node is the rightmost node in the
+tree order.
 
 The
 .code tree-insert-node
@@ -54154,7 +54238,7 @@ argument.
 
 .coNP Function @ tree-insert
 .synb
-.mets (tree-insert < tree << elem )
+.mets (tree-insert < tree < elem <> [ allow-dupe ])
 .syne
 .desc
 The
@@ -54189,6 +54273,17 @@ as if by using the
 .code tree-insert-node
 function.
 
+If one or more elements equal to
+.meta elem
+already exist in the tree, then the behavior is determined by the
+.meta allow-dupe
+argument, which defaults to
+.codn nil .
+The semantics of
+.meta allow-dupe
+is as given in the description of
+.codn tree-insert-node .
+
 The
 .code tree-insert
 function returns the newly inserted
@@ -54239,6 +54334,9 @@ If no such element is found, then
 returns
 .codn nil .
 
+If multiple nodes exist in the tree which have a matching key,
+it is unspecified which one of those nodes is retrieved.
+
 .coNP Function @ tree-lookup
 .synb
 .mets (tree-lookup < tree << key )
@@ -54267,6 +54365,10 @@ A possible implementation is this:
       (key node)))
 .brev
 
+If the tree contains multiple elements which match
+.metn key ,
+it is unspecified which element is retrieved.
+
 .coNP Function @ tree-delete-node
 .synb
 .mets (tree-delete-node < tree << key )
@@ -54297,6 +54399,12 @@ Otherwise, if a matching element is not found, then
 .code nil
 is returned.
 
+If more than one element exists inside
+.meta tree
+which matches
+.metn key ,
+it is unspecified which node is deleted and returned.
+
 .coNP Function @ tree-delete
 .synb
 .mets (tree-delete < tree << key )
@@ -54312,6 +54420,12 @@ the element which matches
 If successful, it returns that element, otherwise it returns
 .codn nil .
 
+If more than one element exists inside
+.meta tree
+which matches
+.metn key ,
+it is unspecified which one is deleted.
+
 Note: the semantics of the
 .code tree-delete
 function can be understood in terms of
@@ -54324,6 +54438,34 @@ A possible implementation is this:
       (key node)))
 .brev
 
+.coNP Function @ tree-delete-specific-node
+.synb
+.mets (tree-delete-specific-node < tree << node )
+.syne
+.desc
+The
+.code tree-delete-specific-node
+function searches
+.meta tree
+to find the specific node given by the
+.meta node
+argument. If
+.meta node
+is inserted into the tree, then it is deleted, and returned.
+
+If
+.meta node
+is not found in the tree, then the tree is unchanged, and
+.code nil
+is returned.
+
+Note: the search for
+.meta node
+is informed by
+.metn node 's
+key, for efficiency. However, if the tree contains duplicates of that key, then
+a linear search takes place among the duplicates.
+
 .coNP Function @ tree-root
 .synb
 .mets (tree-root << tree )
diff --git a/y.tab.c.shipped b/y.tab.c.shipped
index 2dd3c380..8051a192 100644
--- a/y.tab.c.shipped
+++ b/y.tab.c.shipped
@@ -5047,7 +5047,7 @@ yyreduce:
                                    val less_fn = fname_helper(parser, less_fn_name);
                                    val equal_fn = fname_helper(parser, equal_fn_name);
                                    val tr = tree(rest((yyvsp[(2) - (2)].val)), key_fn,
-                                                 less_fn, equal_fn);
+                                                 less_fn, equal_fn, t);
                                      (yyval.val) = rl(tr, num((yyvsp[(1) - (2)].lineno))); } }
     break;