1/*  Part of SWI-Prolog
    2
    3    Author:        Vitor Santos Costa
    4    E-mail:        vscosta@gmail.com
    5    WWW:           http://www.swi-prolog.org
    6    Copyright (c)  2007-2021, Vitor Santos Costa
    7    All rights reserved.
    8
    9    Redistribution and use in source and binary forms, with or without
   10    modification, are permitted provided that the following conditions
   11    are met:
   12
   13    1. Redistributions of source code must retain the above copyright
   14       notice, this list of conditions and the following disclaimer.
   15
   16    2. Redistributions in binary form must reproduce the above copyright
   17       notice, this list of conditions and the following disclaimer in
   18       the documentation and/or other materials provided with the
   19       distribution.
   20
   21    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   24    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   25    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   26    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   27    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   28    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   29    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   30    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   31    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   32    POSSIBILITY OF SUCH DAMAGE.
   33*/
   34
   35:- module(rbtrees,
   36          [ rb_new/1,                   % -Tree
   37            rb_empty/1,                 % ?Tree
   38            rb_lookup/3,                % +Key, -Value, +Tree
   39            rb_update/4,                % +Tree, +Key,          ?NewVal, -NewTree
   40            rb_update/5,                % +Tree, +Key, -OldVal, ?NewVal, -NewTree
   41            rb_apply/4,                 % +Tree, +Key, :G, -NewTree
   42            rb_insert/4,                % +Tree, +Key, ?Value, -NewTree
   43            rb_insert_new/4,            % +Tree, +Key, ?Value, -NewTree
   44            rb_delete/3,                % +Tree, +Key,       -NewTree
   45            rb_delete/4,                % +Tree, +Key, -Val, -NewTree
   46            rb_visit/2,                 % +Tree, -Pairs
   47            rb_keys/2,                  % +Tree, +Keys
   48            rb_map/2,                   % +Tree, :Goal
   49            rb_map/3,                   % +Tree, :Goal, -MappedTree
   50            rb_partial_map/4,           % +Tree, +Keys, :Goal, -MappedTree
   51            rb_fold/4,                  % :Goal, +Tree, +State0, -State
   52            rb_clone/3,                 % +TreeIn, -TreeOut, -Pairs
   53            rb_min/3,                   % +Tree, -Key, -Value
   54            rb_max/3,                   % +Tree, -Key, -Value
   55            rb_del_min/4,               % +Tree, -Key, -Val, -TreeDel
   56            rb_del_max/4,               % +Tree, -Key, -Val, -TreeDel
   57            rb_next/4,                  % +Tree, +Key, -Next, -Value
   58            rb_previous/4,              % +Tree, +Key, -Next, -Value
   59            list_to_rbtree/2,           % +Pairs, -Tree
   60            ord_list_to_rbtree/2,       % +Pairs, -Tree
   61            is_rbtree/1,                % @Tree
   62            rb_size/2,                  % +Tree, -Size
   63            rb_in/3                     % ?Key, ?Value, +Tree
   64          ]).   65:- autoload(library(error), [domain_error/2]).   66
   67/** <module> Red black trees
   68
   69Red-Black trees are balanced search binary trees. They are named because
   70nodes can be classified as either red or   black. The code we include is
   71based on "Introduction  to  Algorithms",   second  edition,  by  Cormen,
   72Leiserson, Rivest and Stein. The library   includes  routines to insert,
   73lookup and delete elements in the tree.
   74
   75A Red black tree is represented as a term t(Nil, Tree), where Nil is the
   76Nil-node, a node shared for each nil-node in  the tree. Any node has the
   77form colour(Left, Key, Value, Right), where _colour_  is one of `red` or
   78`black`.
   79
   80__Warning: instantiation of keys__
   81
   82Red-Black trees depend on  the  Prolog   _standard  order  of  terms_ to
   83organize the keys as a (balanced)  binary   tree.  This implies that any
   84term may be used as a key. The   tree may produce wrong results, such as
   85not being able to find a key, if  the ordering of keys changes after the
   86key has been inserted into the tree.   The user is responsible to ensure
   87that variables used as keys or appearing in  a term used as key that may
   88affect ordering are not  unified,  with   the  exception  of unification
   89against new fresh variables. For this   reason,  _ground_ terms are safe
   90keys. When using non-ground terms, either make sure the variables appear
   91in places that do not affect the   standard order relative to other keys
   92in the tree or make sure to not unify against these variables as long as
   93the tree is being used.
   94
   95@see            library(pairs), library(assoc)
   96@author Vitor Santos Costa, Jan Wielemaker, Samer Abdallah,
   97        Peter Ludemann.
   98@see "Introduction to Algorithms", Second Edition Cormen, Leiserson,
   99     Rivest, and Stein, MIT Press
  100*/
  101
  102% rbtrees.pl is derived from YAP's rbtrees.yap, with some minor editing.
  103% One difference is that the SWI-Prolog version  assumes that a key only
  104% appears once in the tree - the   YAP  code is somewhat inconsistent in
  105% that  (and  even  allows  rb_lookup/3  to    backtrack,  plus  it  has
  106% rb_lookupall/3, which isn't in the SWI-Prolog code).
  107
  108% The code has also been modified to   use SWI-Prolog's '=>' operator to
  109% throw an existence_error(matching_rule, _)  exception   if  Tree isn't
  110% instantiated (if ':-' is used, an  uninstanted   Tree  gets  set to an
  111% empty tree, which probably isn't the desired result).
  112
  113:- meta_predicate
  114    rb_map(+,2,-),
  115    rb_map(?,1),
  116    rb_partial_map(+,+,2,-),
  117    rb_apply(+,+,2,-),
  118    rb_fold(3,+,+,-).  119
  120/*
  121:- use_module(library(type_check)).
  122
  123:- type rbtree(K,V) ---> t(tree(K,V),tree(K,V)).
  124:- type tree(K,V)   ---> black(tree(K,V),K,V,tree(K,V))
  125                       ; red(tree(K,V),K,V,tree(K,V))
  126                       ; ''.
  127:- type cmp ---> (=) ; (<) ; (>).
  128
  129
  130:- pred rb_new(rbtree(_K,_V)).
  131:- pred rb_empty(rbtree(_K,_V)).
  132:- pred rb_lookup(K,V,rbtree(K,V)).
  133:- pred lookup(K,V, tree(K,V)).
  134:- pred lookup(cmp, K, V, tree(K,V)).
  135:- pred rb_min(rbtree(K,V),K,V).
  136:- pred min(tree(K,V),K,V).
  137:- pred rb_max(rbtree(K,V),K,V).
  138:- pred max(tree(K,V),K,V).
  139:- pred rb_next(rbtree(K,V),K,pair(K,V),V).
  140:- pred next(tree(K,V),K,pair(K,V),V,tree(K,V)).
  141*/
  142
  143%!  rb_new(-Tree) is det.
  144%
  145%   Create a new Red-Black tree Tree.
  146%
  147%   @deprecated     Use rb_empty/1.
  148
  149:- det(rb_new/1).  150rb_new(t(Nil,Nil)) :-
  151    Nil = black('',_,_,'').
  152
  153%!  rb_empty(?Tree) is semidet.
  154%
  155%   Succeeds if Tree is an empty Red-Black tree.
  156
  157rb_empty(t(Nil,Nil)) :-
  158    Nil = black('',_,_,'').
  159
  160%!  rb_lookup(+Key, -Value, +Tree) is semidet.
  161%
  162%   True when Value is associated with Key   in the Red-Black tree Tree.
  163%   The given Key may include variables, in   which  case the RB tree is
  164%   searched for a key with equivalent   variables  (using (==)/2). Time
  165%   complexity is O(log N) in the number of elements in the tree.
  166%
  167%   @see rb_in/3 for backtracking over keys.
  168
  169rb_lookup(Key, Val, t(_,Tree)) =>
  170    lookup(Key, Val, Tree).
  171
  172lookup(_Key, _Val, black('',_,_,'')) => fail.
  173lookup(Key, Val, Tree) =>
  174    arg(2,Tree,KA),
  175    compare(Cmp,KA,Key),
  176    lookup(Cmp,Key,Val,Tree).
  177
  178lookup(>, K, V, Tree) :-
  179    arg(1,Tree,NTree),
  180    lookup(K, V, NTree).
  181lookup(<, K, V, Tree) :-
  182    arg(4,Tree,NTree),
  183    lookup(K, V, NTree).
  184lookup(=, _, V, Tree) :-
  185    arg(3,Tree,V).
  186
  187%!  rb_min(+Tree, -Key, -Value) is semidet.
  188%
  189%   Key is the minimum key in Tree, and is associated with Val.
  190
  191rb_min(t(_,Tree), Key, Val) =>
  192    min(Tree, Key, Val).
  193
  194min(red(black('',_,_,_),Key0,Val0,_), Key, Val) => Key0=Key, Val0=Val.
  195min(black(black('',_,_,_),Key0,Val0,_), Key, Val) => Key0=Key, Val0=Val.
  196min(red(Right,_,_,_), Key, Val) =>
  197    min(Right,Key,Val).
  198min(black(Right,_,_,_), Key, Val) =>
  199    min(Right,Key,Val).
  200min('', _Key, _Val) => fail.
  201
  202%!  rb_max(+Tree, -Key, -Value) is semidet.
  203%
  204%   Key is the maximal key in Tree, and is associated with Val.
  205
  206rb_max(t(_,Tree), Key, Val) =>
  207    max(Tree, Key, Val).
  208
  209max(red(_,Key0,Val0,black('',_,_,_)), Key, Val) => Key0=Key, Val0=Val.
  210max(black(_,Key0,Val0,black('',_,_,_)), Key, Val) =>Key0=Key, Val0=Val.
  211max(red(_,_,_,Left), Key, Val) =>
  212    max(Left,Key,Val).
  213max(black(_,_,_,Left), Key, Val) =>
  214    max(Left,Key,Val).
  215max('', _Key, _Val) => fail.
  216
  217%!  rb_next(+Tree, +Key, -Next, -Value) is semidet.
  218%
  219%   Next is the next element after Key   in Tree, and is associated with
  220%   Val. Fails if Key isn't in Tree or if Key is the maximum key.
  221
  222rb_next(t(_,Tree), Key, Next, Val) =>
  223    next(Tree, Key, Next, Val, []).
  224
  225next(black('',_,_,''), _, _, _, _) => fail.
  226next(Tree, Key, Next, Val, Candidate) =>
  227    arg(2,Tree,KA),
  228    arg(3,Tree,VA),
  229    compare(Cmp,KA,Key),
  230    next(Cmp, Key, KA, VA, Next, Val, Tree, Candidate).
  231
  232next(>, K, KA, VA, NK, V, Tree, _) :-
  233    arg(1,Tree,NTree),
  234    next(NTree,K,NK,V,KA-VA).
  235next(<, K, _, _, NK, V, Tree, Candidate) :-
  236    arg(4,Tree,NTree),
  237    next(NTree,K,NK,V,Candidate).
  238next(=, _, _, _, NK, Val, Tree, Candidate) :-
  239    arg(4,Tree,NTree),
  240    (   min(NTree, NK, Val)
  241    ->  true
  242    ;   Candidate = (NK-Val)
  243    ).
  244
  245%!  rb_previous(+Tree, +Key, -Previous, -Value) is semidet.
  246%
  247%   Previous  is  the  previous  element  after  Key  in  Tree,  and  is
  248%   associated with Val. Fails if Key isn't  in   Tree  or if Key is the
  249%   minimum key.
  250
  251rb_previous(t(_,Tree), Key, Previous, Val) =>
  252    previous(Tree, Key, Previous, Val, []).
  253
  254previous(black('',_,_,''), _, _, _, _) => fail.
  255previous(Tree, Key, Previous, Val, Candidate) =>
  256    arg(2,Tree,KA),
  257    arg(3,Tree,VA),
  258    compare(Cmp,KA,Key),
  259    previous(Cmp, Key, KA, VA, Previous, Val, Tree, Candidate).
  260
  261previous(>, K, _, _, NK, V, Tree, Candidate) :-
  262    arg(1,Tree,NTree),
  263    previous(NTree,K,NK,V,Candidate).
  264previous(<, K, KA, VA, NK, V, Tree, _) :-
  265    arg(4,Tree,NTree),
  266    previous(NTree,K,NK,V,KA-VA).
  267previous(=, _, _, _, K, Val, Tree, Candidate) :-
  268    arg(1,Tree,NTree),
  269    (   max(NTree, K, Val)
  270    ->  true
  271    ;   Candidate = (K-Val)
  272    ).
  273
  274%!  rb_update(+Tree, +Key, ?NewVal, -NewTree) is semidet.
  275%
  276%   Tree NewTree is tree Tree, but with   value  for Key associated with
  277%   NewVal. Fails if Key is not in   Tree (using (==)/2). This predicate
  278%   may fail or give  unexpected  results   if  Key  is not sufficiently
  279%   instantiated.
  280%
  281%   @see rb_in/3 for backtracking over keys.
  282
  283rb_update(t(Nil,OldTree), Key, OldVal, Val, NewTree2) =>
  284    NewTree2 = t(Nil,NewTree),
  285    update(OldTree, Key, OldVal, Val, NewTree).
  286
  287%!  rb_update(+Tree, +Key, -OldVal, ?NewVal, -NewTree) is semidet.
  288%
  289% Same as =|rb_update(Tree, Key, NewVal, NewTree)|= but also unifies
  290% OldVal with the value associated with Key in Tree.
  291
  292rb_update(t(Nil,OldTree), Key, Val, NewTree2) =>
  293    NewTree2 = t(Nil,NewTree),
  294    update(OldTree, Key, _, Val, NewTree).
  295
  296update(black(Left,Key0,Val0,Right), Key, OldVal, Val, NewTree) :-
  297    Left \= [],
  298    compare(Cmp,Key0,Key),
  299    (   Cmp == (=)
  300    ->  OldVal = Val0,
  301        NewTree = black(Left,Key0,Val,Right)
  302    ;   Cmp == (>)
  303    ->  NewTree = black(NewLeft,Key0,Val0,Right),
  304        update(Left, Key, OldVal, Val, NewLeft)
  305    ;   NewTree = black(Left,Key0,Val0,NewRight),
  306        update(Right, Key, OldVal, Val, NewRight)
  307    ).
  308update(red(Left,Key0,Val0,Right), Key, OldVal, Val, NewTree) :-
  309    compare(Cmp,Key0,Key),
  310    (   Cmp == (=)
  311    ->  OldVal = Val0,
  312        NewTree = red(Left,Key0,Val,Right)
  313    ;   Cmp == (>)
  314    ->  NewTree = red(NewLeft,Key0,Val0,Right),
  315        update(Left, Key, OldVal, Val, NewLeft)
  316    ;   NewTree = red(Left,Key0,Val0,NewRight),
  317        update(Right, Key, OldVal, Val, NewRight)
  318    ).
  319
  320%!  rb_apply(+Tree, +Key, :G, -NewTree) is semidet.
  321%
  322%   If the value associated  with  key  Key   is  Val0  in  Tree, and if
  323%   call(G,Val0,ValF) holds, then NewTree differs from Tree only in that
  324%   Key is associated with value  ValF  in   tree  NewTree.  Fails if it
  325%   cannot find Key in Tree, or if call(G,Val0,ValF) is not satisfiable.
  326
  327rb_apply(t(Nil,OldTree), Key, Goal, NewTree2) =>
  328    NewTree2 = t(Nil,NewTree),
  329    apply(OldTree, Key, Goal, NewTree).
  330
  331%apply(black('',_,_,''), _, _, _) :- !, fail.
  332apply(black(Left,Key0,Val0,Right), Key, Goal,
  333      black(NewLeft,Key0,Val,NewRight)) :-
  334    Left \= [],
  335    compare(Cmp,Key0,Key),
  336    (   Cmp == (=)
  337    ->  NewLeft = Left,
  338        NewRight = Right,
  339        call(Goal,Val0,Val)
  340    ;   Cmp == (>)
  341    ->  NewRight = Right,
  342        Val = Val0,
  343        apply(Left, Key, Goal, NewLeft)
  344    ;   NewLeft = Left,
  345        Val = Val0,
  346        apply(Right, Key, Goal, NewRight)
  347    ).
  348apply(red(Left,Key0,Val0,Right), Key, Goal,
  349      red(NewLeft,Key0,Val,NewRight)) :-
  350    compare(Cmp,Key0,Key),
  351    (   Cmp == (=)
  352    ->  NewLeft = Left,
  353        NewRight = Right,
  354        call(Goal,Val0,Val)
  355    ;   Cmp == (>)
  356    ->  NewRight = Right,
  357        Val = Val0,
  358        apply(Left, Key, Goal, NewLeft)
  359    ;   NewLeft = Left,
  360        Val = Val0,
  361        apply(Right, Key, Goal, NewRight)
  362    ).
  363
  364%!  rb_in(?Key, ?Value, +Tree) is nondet.
  365%
  366%   True when Key-Value is a key-value pair in red-black tree Tree. Same
  367%   as below, but does not materialize the pairs.
  368%
  369%        rb_visit(Tree, Pairs), member(Key-Value, Pairs)
  370%
  371%   Leaves a choicepoint  even  if  Key   is  instantiated;  to  avoid a
  372%   choicepoint, use rb_lookup/3.
  373
  374rb_in(Key, Val, t(_,T)) =>
  375    enum(Key, Val, T).
  376
  377enum(Key, Val, black(L,K,V,R)) =>
  378    L \= '',
  379    enum_cases(Key, Val, L, K, V, R).
  380enum(Key, Val, red(L,K,V,R)) =>
  381    enum_cases(Key, Val, L, K, V, R).
  382enum(_Key, _Val, _Tree) => fail.
  383
  384enum_cases(Key, Val, L, _, _, _) :-
  385    enum(Key, Val, L).
  386enum_cases(Key, Val, _, Key, Val, _).
  387enum_cases(Key, Val, _, _, _, R) :-
  388    enum(Key, Val, R).
  389
  390
  391
  392                 /*******************************
  393                 *       TREE INSERTION         *
  394                 *******************************/
  395
  396% We don't use parent nodes, so we may have to fix the root.
  397
  398%!  rb_insert(+Tree, +Key, ?Value, -NewTree) is det.
  399%
  400%   Add an element with key Key and Value   to  the tree Tree creating a
  401%   new red-black tree NewTree. If Key is  a key in Tree, the associated
  402%   value is replaced by Value.  See   also  rb_insert_new/4. Does _not_
  403%   validate that Key is sufficiently instantiated   to  ensure the tree
  404%   remains valid if a key is further instantiated.
  405
  406:- det(rb_insert/4).  407rb_insert(t(Nil,Tree0),Key,Val,NewTree) =>
  408    NewTree = t(Nil,Tree),
  409    insert(Tree0,Key,Val,Nil,Tree).
  410
  411
  412insert(Tree0,Key,Val,Nil,Tree) :-
  413    insert2(Tree0,Key,Val,Nil,TreeI,_),
  414    fix_root(TreeI,Tree).
  415
  416%
  417% Cormen et al present the algorithm as
  418% (1) standard tree insertion;
  419% (2) from the viewpoint of the newly inserted node:
  420%     partially fix the tree;
  421%     move upwards
  422% until reaching the root.
  423%
  424% We do it a little bit different:
  425%
  426% (1) standard tree insertion;
  427% (2) move upwards:
  428%      when reaching a black node;
  429%        if the tree below may be broken, fix it.
  430% We take advantage of Prolog unification
  431% to do several operations in a single go.
  432%
  433
  434
  435
  436%
  437% actual insertion
  438%
  439insert2(black('',_,_,''), K, V, Nil, T, Status) =>
  440    T = red(Nil,K,V,Nil),
  441    Status = not_done.
  442insert2(red(L,K0,V0,R), K, V, Nil, NT, Flag) =>
  443    (   K @< K0
  444    ->  NT = red(NL,K0,V0,R),
  445        insert2(L, K, V, Nil, NL, Flag)
  446    ;   K == K0
  447    ->  NT = red(L,K0,V,R),
  448        Flag = done
  449    ;   NT = red(L,K0,V0,NR),
  450        insert2(R, K, V, Nil, NR, Flag)
  451    ).
  452insert2(black(L,K0,V0,R), K, V, Nil, NT, Flag) =>
  453    (   K @< K0
  454    ->  insert2(L, K, V, Nil, IL, Flag0),
  455        fix_left(Flag0, black(IL,K0,V0,R), NT, Flag)
  456    ;   K == K0
  457    ->  NT = black(L,K0,V,R),
  458        Flag = done
  459    ;   insert2(R, K, V, Nil, IR, Flag0),
  460        fix_right(Flag0, black(L,K0,V0,IR), NT, Flag)
  461    ).
  462
  463% We don't use parent nodes, so we may have to fix the root.
  464
  465%!  rb_insert_new(+Tree, +Key, ?Value, -NewTree) is semidet.
  466%
  467%   Add a new element with key Key and Value to the tree Tree creating a
  468%   new red-black tree NewTree. Fails if  Key   is  a  key in Tree. Does
  469%   _not_ validate that Key is sufficiently   instantiated to ensure the
  470%   tree remains valid if a key is further instantiated.
  471
  472rb_insert_new(t(Nil,Tree0),Key,Val,NewTree) =>
  473    NewTree = t(Nil,Tree),
  474    insert_new(Tree0,Key,Val,Nil,Tree).
  475
  476insert_new(Tree0,Key,Val,Nil,Tree) :-
  477    insert_new_2(Tree0,Key,Val,Nil,TreeI,_),
  478    fix_root(TreeI,Tree).
  479
  480%
  481% actual insertion, copied from insert2
  482%
  483insert_new_2(black('',_,_,''), K, V, Nil, T, Status) =>
  484    T = red(Nil,K,V,Nil),
  485    Status = not_done.
  486insert_new_2(red(L,K0,V0,R), K, V, Nil, NT, Flag) =>
  487    (   K @< K0
  488    ->  NT = red(NL,K0,V0,R),
  489        insert_new_2(L, K, V, Nil, NL, Flag)
  490    ;   K == K0
  491    ->  fail
  492    ;   NT = red(L,K0,V0,NR),
  493        insert_new_2(R, K, V, Nil, NR, Flag)
  494    ).
  495insert_new_2(black(L,K0,V0,R), K, V, Nil, NT, Flag) =>
  496    (   K @< K0
  497    ->  insert_new_2(L, K, V, Nil, IL, Flag0),
  498        fix_left(Flag0, black(IL,K0,V0,R), NT, Flag)
  499    ;   K == K0
  500    ->  fail
  501    ;   insert_new_2(R, K, V, Nil, IR, Flag0),
  502        fix_right(Flag0, black(L,K0,V0,IR), NT, Flag)
  503    ).
  504
  505%
  506% make sure the root is always black.
  507%
  508:- det(fix_root/2).  509fix_root(black(L,K,V,R), Root) => Root = black(L,K,V,R).
  510fix_root(red(L,K,V,R), Root) => Root = black(L,K,V,R).
  511
  512%
  513% How to fix if we have inserted on the left
  514%
  515:- det(fix_left/4).  516fix_left(done,T0,T,Done) => T = T0, Done = done.
  517fix_left(not_done,Tmp,Final,Done) =>
  518    fix_left(Tmp,Final,Done).
  519
  520:- det(fix_left/3).  521%
  522% case 1 of RB: just need to change colors.
  523%
  524fix_left(black(red(Al,AK,AV,red(Be,BK,BV,Ga)),KC,VC,red(De,KD,VD,Ep)),
  525        red(black(Al,AK,AV,red(Be,BK,BV,Ga)),KC,VC,black(De,KD,VD,Ep)),
  526        not_done) :- !.
  527fix_left(black(red(red(Al,KA,VA,Be),KB,VB,Ga),KC,VC,red(De,KD,VD,Ep)),
  528        red(black(red(Al,KA,VA,Be),KB,VB,Ga),KC,VC,black(De,KD,VD,Ep)),
  529        not_done) :- !.
  530%
  531% case 2 of RB: got a knee so need to do rotations
  532%
  533fix_left(black(red(Al,KA,VA,red(Be,KB,VB,Ga)),KC,VC,De),
  534        black(red(Al,KA,VA,Be),KB,VB,red(Ga,KC,VC,De)),
  535        done) :- !.
  536%
  537% case 3 of RB: got a line
  538%
  539fix_left(black(red(red(Al,KA,VA,Be),KB,VB,Ga),KC,VC,De),
  540        black(red(Al,KA,VA,Be),KB,VB,red(Ga,KC,VC,De)),
  541        done) :- !.
  542%
  543% case 4 of RB: nothing to do
  544%
  545fix_left(T,T,done).
  546
  547%
  548% How to fix if we have inserted on the right
  549%
  550:- det(fix_right/4).  551fix_right(done,T0,T,Done) => T0 = T, Done = done.
  552fix_right(not_done,Tmp,Final,Done) =>
  553    fix_right(Tmp,Final,Done).
  554
  555:- det(fix_right/3).  556%
  557% case 1 of RB: just need to change colors.
  558%
  559fix_right(black(red(Ep,KD,VD,De),KC,VC,red(red(Ga,KB,VB,Be),KA,VA,Al)),
  560          red(black(Ep,KD,VD,De),KC,VC,black(red(Ga,KB,VB,Be),KA,VA,Al)),
  561          not_done) :- !.
  562fix_right(black(red(Ep,KD,VD,De),KC,VC,red(Ga,Ka,Va,red(Be,KB,VB,Al))),
  563          red(black(Ep,KD,VD,De),KC,VC,black(Ga,Ka,Va,red(Be,KB,VB,Al))),
  564          not_done) :- !.
  565%
  566% case 2 of RB: got a knee so need to do rotations
  567%
  568fix_right(black(De,KC,VC,red(red(Ga,KB,VB,Be),KA,VA,Al)),
  569          black(red(De,KC,VC,Ga),KB,VB,red(Be,KA,VA,Al)),
  570          done) :- !.
  571%
  572% case 3 of RB: got a line
  573%
  574fix_right(black(De,KC,VC,red(Ga,KB,VB,red(Be,KA,VA,Al))),
  575          black(red(De,KC,VC,Ga),KB,VB,red(Be,KA,VA,Al)),
  576          done) :- !.
  577%
  578% case 4 of RB: nothing to do.
  579%
  580fix_right(T,T,done).
  581
  582
  583%!  rb_delete(+Tree, +Key, -NewTree).
  584%
  585%   Delete element with key Key from the  tree Tree, returning the value
  586%   Val associated with the key and a new  tree NewTree. Fails if Key is
  587%   not in Tree  (using  (==)/2).
  588%
  589%   @see rb_in/3 for backtracking over keys.
  590
  591rb_delete(t(Nil,T), K, NewTree) =>
  592    NewTree = t(Nil,NT),
  593    delete(T, K, _, NT, _).
  594
  595%!  rb_delete(+Tree, +Key, -Val, -NewTree).
  596%
  597%   Same as rb_delete(Tree, Key, NewTree), but also unifies Val with the
  598%   value associated with Key in Tree.
  599
  600rb_delete(t(Nil,T), K, V, NewTree) =>
  601    NewTree = t(Nil,NT),
  602    delete(T, K, V0, NT, _),
  603    V = V0.
  604
  605%
  606% I am afraid our representation is not as nice for delete
  607%
  608delete(red(L,K0,V0,R), K, V, NT, Flag) =>
  609    delete_red(L,K0,V0,R, K, V, NT, Flag).
  610delete(black(L,K0,V0,R), K, V, NT, Flag) =>
  611    delete_black(L,K0,V0,R, K, V, NT, Flag).
  612delete('', _K, _V, _NT, _Flag) =>
  613    fail.
  614
  615delete_red(L,K0,V0,R, K, V, NT, Flag), K @< K0 =>
  616    delete(L, K, V, NL, Flag0),
  617    fixup_left(Flag0,red(NL,K0,V0,R),NT, Flag).
  618delete_red(L,K0,V0,R, K, V, NT, Flag), K @> K0 =>
  619    delete(R, K, V, NR, Flag0),
  620    fixup_right(Flag0,red(L,K0,V0,NR),NT, Flag).
  621delete_red(L,_,V0,R, _, V, Out, Flag) => % K == K0,
  622    V0 = V,
  623    delete_red_node(L,R,Out,Flag).
  624
  625delete_black(L,K0,V0,R, K, V, NT, Flag), K @< K0 =>
  626    delete(L, K, V, NL, Flag0),
  627    fixup_left(Flag0,black(NL,K0,V0,R),NT, Flag).
  628delete_black(L,K0,V0,R, K, V, NT, Flag), K @> K0 =>
  629    delete(R, K, V, NR, Flag0),
  630    fixup_right(Flag0,black(L,K0,V0,NR),NT, Flag).
  631delete_black(L,_,V0,R, _, V, Out, Flag) => % K == K0,
  632    V0 = V,
  633    delete_black_node(L,R,Out,Flag).
  634
  635%!  rb_del_min(+Tree, -Key, -Val, -NewTree)
  636%
  637%   Delete the least element from the tree  Tree, returning the key Key,
  638%   the value Val associated with the key  and a new tree NewTree. Fails
  639%   if Tree is empty.
  640
  641rb_del_min(t(Nil,T), K, Val, NewTree) =>
  642    NewTree = t(Nil,NT),
  643    del_min(T, K, Val, Nil, NT, _).
  644
  645del_min(red(black('',_,_,_),K,V,R), K, V, Nil, Out, Flag) :-
  646    !,
  647    delete_red_node(Nil,R,Out,Flag).
  648del_min(red(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  649    del_min(L, K, V, Nil, NL, Flag0),
  650    fixup_left(Flag0,red(NL,K0,V0,R), NT, Flag).
  651del_min(black(black('',_,_,_),K,V,R), K, V, Nil, Out, Flag) :-
  652    !,
  653    delete_black_node(Nil,R,Out,Flag).
  654del_min(black(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  655    del_min(L, K, V, Nil, NL, Flag0),
  656    fixup_left(Flag0,black(NL,K0,V0,R),NT, Flag).
  657
  658
  659%!  rb_del_max(+Tree, -Key, -Val, -NewTree)
  660%
  661%   Delete the largest element from  the   tree  Tree, returning the key
  662%   Key, the value Val associated with the   key and a new tree NewTree.
  663%   Fails if Tree is empty.
  664
  665rb_del_max(t(Nil,T), K, Val, NewTree) =>
  666    NewTree = t(Nil,NT),
  667    del_max(T, K, Val, Nil, NT, _).
  668
  669del_max(red(L,K,V,black('',_,_,_)), K, V, Nil, Out, Flag) :-
  670    !,
  671    delete_red_node(L,Nil,Out,Flag).
  672del_max(red(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  673    del_max(R, K, V, Nil, NR, Flag0),
  674    fixup_right(Flag0,red(L,K0,V0,NR),NT, Flag).
  675del_max(black(L,K,V,black('',_,_,_)), K, V, Nil, Out, Flag) :-
  676    !,
  677    delete_black_node(L,Nil,Out,Flag).
  678del_max(black(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  679    del_max(R, K, V, Nil, NR, Flag0),
  680    fixup_right(Flag0,black(L,K0,V0,NR), NT, Flag).
  681
  682delete_red_node(L1,L2,L1,done) :- L1 == L2, !.
  683delete_red_node(black('',_,_,''),R,R,done) :-  !.
  684delete_red_node(L,black('',_,_,''),L,done) :-  !.
  685delete_red_node(L,R,Out,Done) :-
  686    delete_next(R,NK,NV,NR,Done0),
  687    fixup_right(Done0,red(L,NK,NV,NR),Out,Done).
  688
  689delete_black_node(L1,L2,L1,not_done) :-         L1 == L2, !.
  690delete_black_node(black('',_,_,''),red(L,K,V,R),black(L,K,V,R),done) :- !.
  691delete_black_node(black('',_,_,''),R,R,not_done) :- !.
  692delete_black_node(red(L,K,V,R),black('',_,_,''),black(L,K,V,R),done) :- !.
  693delete_black_node(L,black('',_,_,''),L,not_done) :- !.
  694delete_black_node(L,R,Out,Done) :-
  695    delete_next(R,NK,NV,NR,Done0),
  696    fixup_right(Done0,black(L,NK,NV,NR),Out,Done).
  697
  698delete_next(red(black('',_,_,''),K,V,R),K,V,R,done) :-  !.
  699delete_next(black(black('',_,_,''),K,V,red(L1,K1,V1,R1)),
  700        K,V,black(L1,K1,V1,R1),done) :- !.
  701delete_next(black(black('',_,_,''),K,V,R),K,V,R,not_done) :- !.
  702delete_next(red(L,K,V,R),K0,V0,Out,Done) :-
  703    delete_next(L,K0,V0,NL,Done0),
  704    fixup_left(Done0,red(NL,K,V,R),Out,Done).
  705delete_next(black(L,K,V,R),K0,V0,Out,Done) :-
  706    delete_next(L,K0,V0,NL,Done0),
  707    fixup_left(Done0,black(NL,K,V,R),Out,Done).
  708
  709fixup_left(done,T,T,done).
  710fixup_left(not_done,T,NT,Done) :-
  711    fixup2(T,NT,Done).
  712
  713%
  714% case 1: x moves down, so we have to try to fix it again.
  715% case 1 -> 2,3,4 -> done
  716%
  717fixup2(black(black(Al,KA,VA,Be),KB,VB,
  718             red(black(Ga,KC,VC,De),KD,VD,
  719                 black(Ep,KE,VE,Fi))),
  720        black(T1,KD,VD,black(Ep,KE,VE,Fi)),done) :-
  721    !,
  722    fixup2(red(black(Al,KA,VA,Be),KB,VB,black(Ga,KC,VC,De)),
  723            T1,
  724            _).
  725%
  726% case 2: x moves up, change one to red
  727%
  728fixup2(red(black(Al,KA,VA,Be),KB,VB,
  729           black(black(Ga,KC,VC,De),KD,VD,
  730                 black(Ep,KE,VE,Fi))),
  731        black(black(Al,KA,VA,Be),KB,VB,
  732              red(black(Ga,KC,VC,De),KD,VD,
  733                  black(Ep,KE,VE,Fi))),done) :- !.
  734fixup2(black(black(Al,KA,VA,Be),KB,VB,
  735             black(black(Ga,KC,VC,De),KD,VD,
  736                   black(Ep,KE,VE,Fi))),
  737        black(black(Al,KA,VA,Be),KB,VB,
  738              red(black(Ga,KC,VC,De),KD,VD,
  739                  black(Ep,KE,VE,Fi))),not_done) :- !.
  740%
  741% case 3: x stays put, shift left and do a 4
  742%
  743fixup2(red(black(Al,KA,VA,Be),KB,VB,
  744           black(red(Ga,KC,VC,De),KD,VD,
  745                 black(Ep,KE,VE,Fi))),
  746        red(black(black(Al,KA,VA,Be),KB,VB,Ga),KC,VC,
  747            black(De,KD,VD,black(Ep,KE,VE,Fi))),
  748        done) :- !.
  749fixup2(black(black(Al,KA,VA,Be),KB,VB,
  750             black(red(Ga,KC,VC,De),KD,VD,
  751                   black(Ep,KE,VE,Fi))),
  752        black(black(black(Al,KA,VA,Be),KB,VB,Ga),KC,VC,
  753              black(De,KD,VD,black(Ep,KE,VE,Fi))),
  754        done) :- !.
  755%
  756% case 4: rotate left, get rid of red
  757%
  758fixup2(red(black(Al,KA,VA,Be),KB,VB,
  759           black(C,KD,VD,red(Ep,KE,VE,Fi))),
  760        red(black(black(Al,KA,VA,Be),KB,VB,C),KD,VD,
  761            black(Ep,KE,VE,Fi)),
  762        done).
  763fixup2(black(black(Al,KA,VA,Be),KB,VB,
  764             black(C,KD,VD,red(Ep,KE,VE,Fi))),
  765       black(black(black(Al,KA,VA,Be),KB,VB,C),KD,VD,
  766             black(Ep,KE,VE,Fi)),
  767       done).
  768
  769fixup_right(done,T,T,done).
  770fixup_right(not_done,T,NT,Done) :-
  771    fixup3(T,NT,Done).
  772
  773% case 1: x moves down, so we have to try to fix it again.
  774% case 1 -> 2,3,4 -> done
  775%
  776fixup3(black(red(black(Fi,KE,VE,Ep),KD,VD,
  777                 black(De,KC,VC,Ga)),KB,VB,
  778             black(Be,KA,VA,Al)),
  779        black(black(Fi,KE,VE,Ep),KD,VD,T1),done) :-
  780    !,
  781    fixup3(red(black(De,KC,VC,Ga),KB,VB,
  782               black(Be,KA,VA,Al)),T1,_).
  783
  784%
  785% case 2: x moves up, change one to red
  786%
  787fixup3(red(black(black(Fi,KE,VE,Ep),KD,VD,
  788                 black(De,KC,VC,Ga)),KB,VB,
  789           black(Be,KA,VA,Al)),
  790       black(red(black(Fi,KE,VE,Ep),KD,VD,
  791                 black(De,KC,VC,Ga)),KB,VB,
  792             black(Be,KA,VA,Al)),
  793       done) :- !.
  794fixup3(black(black(black(Fi,KE,VE,Ep),KD,VD,
  795                   black(De,KC,VC,Ga)),KB,VB,
  796             black(Be,KA,VA,Al)),
  797       black(red(black(Fi,KE,VE,Ep),KD,VD,
  798                 black(De,KC,VC,Ga)),KB,VB,
  799             black(Be,KA,VA,Al)),
  800       not_done):- !.
  801%
  802% case 3: x stays put, shift left and do a 4
  803%
  804fixup3(red(black(black(Fi,KE,VE,Ep),KD,VD,
  805                 red(De,KC,VC,Ga)),KB,VB,
  806           black(Be,KA,VA,Al)),
  807       red(black(black(Fi,KE,VE,Ep),KD,VD,De),KC,VC,
  808           black(Ga,KB,VB,black(Be,KA,VA,Al))),
  809       done) :- !.
  810fixup3(black(black(black(Fi,KE,VE,Ep),KD,VD,
  811                   red(De,KC,VC,Ga)),KB,VB,
  812             black(Be,KA,VA,Al)),
  813       black(black(black(Fi,KE,VE,Ep),KD,VD,De),KC,VC,
  814             black(Ga,KB,VB,black(Be,KA,VA,Al))),
  815       done) :- !.
  816%
  817% case 4: rotate right, get rid of red
  818%
  819fixup3(red(black(red(Fi,KE,VE,Ep),KD,VD,C),KB,VB,black(Be,KA,VA,Al)),
  820       red(black(Fi,KE,VE,Ep),KD,VD,black(C,KB,VB,black(Be,KA,VA,Al))),
  821       done).
  822fixup3(black(black(red(Fi,KE,VE,Ep),KD,VD,C),KB,VB,black(Be,KA,VA,Al)),
  823       black(black(Fi,KE,VE,Ep),KD,VD,black(C,KB,VB,black(Be,KA,VA,Al))),
  824       done).
  825
  826%!  rb_visit(+Tree, -Pairs) is det.
  827%
  828%   Pairs is an infix visit of tree Tree, where each element of Pairs is
  829%   of the form Key-Value.
  830
  831:- det(rb_visit/2).  832rb_visit(t(_,T),Lf) =>
  833    visit(T,[],Lf).
  834
  835visit(black('',_,_,_),L0,L) => L0 = L.
  836visit(red(L,K,V,R),L0,Lf) =>
  837    visit(L,[K-V|L1],Lf),
  838    visit(R,L0,L1).
  839visit(black(L,K,V,R),L0,Lf) =>
  840    visit(L,[K-V|L1],Lf),
  841    visit(R,L0,L1).
  842
  843:- meta_predicate map(?,2,?,?).  % this is required.
  844
  845%!  rb_map(+T, :Goal) is semidet.
  846%
  847%   True if call(Goal, Value) is true for all nodes in T.
  848
  849rb_map(t(Nil,Tree),Goal,NewTree2) =>
  850    NewTree2 = t(Nil,NewTree),
  851    map(Tree,Goal,NewTree,Nil).
  852
  853
  854map(black('',_,_,''),_,Nil0,Nil) => Nil0 = Nil.
  855map(red(L,K,V,R),Goal,NewTree,Nil) =>
  856    NewTree = red(NL,K,NV,NR),
  857    call(Goal,V,NV),
  858    map(L,Goal,NL,Nil),
  859    map(R,Goal,NR,Nil).
  860map(black(L,K,V,R),Goal,NewTree,Nil) =>
  861    NewTree = black(NL,K,NV,NR),
  862    call(Goal,V,NV),
  863    map(L,Goal,NL,Nil),
  864    map(R,Goal,NR,Nil).
  865
  866:- meta_predicate map(?,1).  % this is required.
  867
  868%!  rb_map(+Tree, :G, -NewTree) is semidet.
  869%
  870%   For all nodes Key in the tree Tree, if the value associated with key
  871%   Key is Val0 in tree Tree, and   if call(G,Val0,ValF) holds, then the
  872%   value  associated  with  Key  in   NewTree    is   ValF.   Fails  if
  873%   call(G,Val0,ValF)  is  not  satisfiable  for  all   Val0.  If  G  is
  874%   non-deterministic, rb_map/3 will backtrack over  all possible values
  875%   from call(G,Val0,ValF). You should not depend   on the order of tree
  876%   traversal (currently: key order).
  877
  878rb_map(t(_,Tree),Goal) =>
  879    map(Tree,Goal).
  880
  881
  882map(black('',_,_,''),_) => true.
  883map(red(L,_,V,R),Goal) =>
  884    call(Goal,V),
  885    map(L,Goal),
  886    map(R,Goal).
  887map(black(L,_,V,R),Goal) =>
  888    call(Goal,V),
  889    map(L,Goal),
  890    map(R,Goal).
  891
  892%!  rb_fold(:Goal, +Tree, +State0, -State).
  893%
  894%   Fold the given predicate  over  all   the  key-value  pairs in Tree,
  895%   starting with initial state State0  and   returning  the final state
  896%   State. Pred is called as
  897%
  898%       call(Pred, Key-Value, State1, State2)
  899%
  900%   Determinism depends on Goal.
  901
  902rb_fold(Pred, t(_,T), S1, S2) =>
  903    fold(T, Pred, S1, S2).
  904
  905fold(black(L,K,V,R), Pred) -->
  906    (   {L == ''}
  907    ->  []
  908    ;   fold_parts(Pred, L, K-V, R)
  909    ).
  910fold(red(L,K,V,R), Pred) -->
  911    fold_parts(Pred, L, K-V, R).
  912
  913fold_parts(Pred, L, KV, R) -->
  914    fold(L, Pred),
  915    call(Pred, KV),
  916    fold(R, Pred).
  917
  918%!  rb_clone(+TreeIn, -TreeOut, -Pairs) is det.
  919%
  920%   `Clone' the red-back tree TreeIn into a   new  tree TreeOut with the
  921%   same keys as the original but with all values set to unbound values.
  922%   Pairs is a list containing all new nodes as pairs K-V.
  923
  924:- det(rb_clone/3).  925rb_clone(t(Nil,T),TreeOut,Ns) =>
  926    TreeOut = t(Nil,NT),
  927    clone(T,Nil,NT,Ns,[]).
  928
  929clone(black('',_,_,''),Nil0,Nil,Ns0,Ns) => Nil0=Nil, Ns0=Ns.
  930clone(red(L,K,_,R),Nil,TreeOut,NsF,Ns0) =>
  931    TreeOut = red(NL,K,NV,NR),
  932    clone(L,Nil,NL,NsF,[K-NV|Ns1]),
  933    clone(R,Nil,NR,Ns1,Ns0).
  934clone(black(L,K,_,R),Nil,TreeOut,NsF,Ns0) =>
  935    TreeOut = black(NL,K,NV,NR),
  936    clone(L,Nil,NL,NsF,[K-NV|Ns1]),
  937    clone(R,Nil,NR,Ns1,Ns0).
  938
  939%!  rb_partial_map(+Tree, +Keys, :G, -NewTree)
  940%
  941%   For all nodes Key in Keys, if the   value associated with key Key is
  942%   Val0 in tree Tree, and if   call(G,Val0,ValF)  holds, then the value
  943%   associated with Key in NewTree is ValF,   otherwise  it is the value
  944%   associated with the key in Tree. Fails if   Key  isn't in Tree or if
  945%   call(G,Val0,ValF) is not satisfiable for all   Val0 in Keys. Assumes
  946%   keys are sorted and not repeated (fails if this is not true).
  947
  948rb_partial_map(t(Nil,T0), Map, Goal, NewTree) =>
  949    NewTree = t(Nil,TF),
  950    partial_map(T0, Map, [], Nil, Goal, TF).
  951
  952partial_map(T,[],[],_,_,T) :- !.
  953partial_map(black('',_,_,_),Map,Map,Nil,_,Nil) :- !.
  954partial_map(red(L,K,V,R),Map,MapF,Nil,Goal,red(NL,K,NV,NR)) :-
  955    partial_map(L,Map,MapI,Nil,Goal,NL),
  956    (   MapI == []
  957    ->  NR = R, NV = V, MapF = []
  958    ;   MapI = [K1|MapR],
  959        (   K == K1
  960        ->  (   call(Goal,V,NV)
  961            ->  true
  962            ;   NV = V
  963            ),
  964            MapN = MapR
  965        ;   NV = V,
  966            MapN = MapI
  967        ),
  968        partial_map(R,MapN,MapF,Nil,Goal,NR)
  969    ).
  970partial_map(black(L,K,V,R),Map,MapF,Nil,Goal,black(NL,K,NV,NR)) :-
  971    partial_map(L,Map,MapI,Nil,Goal,NL),
  972    (   MapI == []
  973    ->  NR = R, NV = V, MapF = []
  974    ;   MapI = [K1|MapR],
  975        (   K == K1
  976        ->  (   call(Goal,V,NV)
  977            ->  true
  978            ;   NV = V
  979            ),
  980            MapN = MapR
  981        ;   NV = V,
  982            MapN = MapI
  983        ),
  984        partial_map(R,MapN,MapF,Nil,Goal,NR)
  985    ).
  986
  987
  988%!  rb_keys(+Tree, -Keys) is det.
  989%
  990%   Keys is unified with an ordered list   of  all keys in the Red-Black
  991%   tree Tree.
  992
  993:- det(rb_keys/2).  994rb_keys(t(_,T),Lf) =>
  995    keys(T,[],Lf).
  996
  997keys(black('',_,_,''),L0,L) => L0 = L.
  998keys(red(L,K,_,R),L0,Lf) =>
  999    keys(L,[K|L1],Lf),
 1000    keys(R,L0,L1).
 1001keys(black(L,K,_,R),L0,Lf) =>
 1002    keys(L,[K|L1],Lf),
 1003    keys(R,L0,L1).
 1004
 1005
 1006%!  list_to_rbtree(+List, -Tree) is det.
 1007%
 1008%   Tree is the red-black tree  corresponding   to  the mapping in List,
 1009%   which should be a list of Key-Value   pairs. List should not contain
 1010%   more than one entry for each distinct key, but this is not validated
 1011%   by list_to_rbtree/2.
 1012
 1013:- det(list_to_rbtree/2). 1014list_to_rbtree(List, T) :-
 1015    sort(List,Sorted),
 1016    ord_list_to_rbtree(Sorted, T).
 1017
 1018%!  ord_list_to_rbtree(+List, -Tree) is det.
 1019%
 1020%   Tree is the red-black tree  corresponding   to  the  mapping in list
 1021%   List, which should be a list  of   Key-Value  pairs. List should not
 1022%   contain more than one entry for each   distinct key, but this is not
 1023%   validated by ord_list_to_rbtree/2. List is assumed
 1024%   to be sorted according to the standard order of terms.
 1025
 1026:- det(ord_list_to_rbtree/2). 1027ord_list_to_rbtree([], Tree) =>
 1028    Tree = t(Nil,Nil),
 1029    Nil = black('', _, _, '').
 1030ord_list_to_rbtree([K-V], Tree) =>
 1031    Tree = t(Nil,black(Nil,K,V,Nil)),
 1032    Nil = black('', _, _, '').
 1033ord_list_to_rbtree(List, Tree2) =>
 1034    Tree2 = t(Nil,Tree),
 1035    Nil = black('', _, _, ''),
 1036    Ar =.. [seq|List],
 1037    functor(Ar,_,L),
 1038    Height is truncate(log(L)/log(2)),
 1039    construct_rbtree(1, L, Ar, Height, Nil, Tree).
 1040
 1041construct_rbtree(L, M, _, _, Nil, Nil) :- M < L, !.
 1042construct_rbtree(L, L, Ar, Depth, Nil, Node) :-
 1043    !,
 1044    arg(L, Ar, K-Val),
 1045    build_node(Depth, Nil, K, Val, Nil, Node).
 1046construct_rbtree(I0, Max, Ar, Depth, Nil, Node) :-
 1047    I is (I0+Max)//2,
 1048    arg(I, Ar, K-Val),
 1049    build_node(Depth, Left, K, Val, Right, Node),
 1050    I1 is I-1,
 1051    NewDepth is Depth-1,
 1052    construct_rbtree(I0, I1, Ar, NewDepth, Nil, Left),
 1053    I2 is I+1,
 1054    construct_rbtree(I2, Max, Ar, NewDepth, Nil, Right).
 1055
 1056build_node( 0, Left, K, Val, Right, red(Left, K, Val, Right)) :- !.
 1057build_node( _, Left, K, Val, Right, black(Left, K, Val, Right)).
 1058
 1059
 1060%!  rb_size(+Tree, -Size) is det.
 1061%
 1062%   Size is the number of elements in Tree.
 1063
 1064:- det(rb_size/2). 1065rb_size(t(_,T),Size) =>
 1066    size(T,0,Size).
 1067
 1068size(black('',_,_,_),Sz,Sz) :- !.
 1069size(red(L,_,_,R),Sz0,Szf) :-
 1070    Sz1 is Sz0+1,
 1071    size(L,Sz1,Sz2),
 1072    size(R,Sz2,Szf).
 1073size(black(L,_,_,R),Sz0,Szf) :-
 1074    Sz1 is Sz0+1,
 1075    size(L,Sz1,Sz2),
 1076    size(R,Sz2,Szf).
 1077
 1078%!  is_rbtree(@Term) is semidet.
 1079%
 1080%   True if Term is a valid Red-Black   tree. Processes the entire tree,
 1081%   checking the coloring of the nodes, the  balance and the ordering of
 1082%   keys.    Does _not_ validate that keys are sufficiently instantiated
 1083%   to ensure the tree remains valid if a key is further instantiated.
 1084
 1085is_rbtree(X), var(X) =>
 1086    fail.
 1087is_rbtree(t(Nil,Nil)) => true.
 1088is_rbtree(t(_,T)) =>
 1089    Err = error(_,_),
 1090    catch(check_rbtree(T), Err, is_rbtree_error(Err)).
 1091is_rbtree(_) =>
 1092    fail.
 1093
 1094is_rbtree_error(Err), Err = error(resource_error(_),_) => throw(Err).
 1095is_rbtree_error(_) => fail.
 1096
 1097% This code checks if a tree is ordered and a rbtree
 1098
 1099check_rbtree(black(L,K,_,R)) =>
 1100    find_path_blacks(L, 0, Bls),
 1101    check_rbtree(L,-inf,K,Bls),
 1102    check_rbtree(R,K,+inf,Bls).
 1103check_rbtree(Node), Node = red(_,_,_,_) =>
 1104    domain_error(rb_black, Node).
 1105
 1106
 1107find_path_blacks(black('',_,_,''), Bls0, Bls) => Bls = Bls0.
 1108find_path_blacks(black(L,_,_,_), Bls0, Bls) =>
 1109    Bls1 is Bls0+1,
 1110    find_path_blacks(L, Bls1, Bls).
 1111find_path_blacks(red(L,_,_,_), Bls0, Bls) =>
 1112    find_path_blacks(L, Bls0, Bls).
 1113
 1114check_rbtree(black('',_,_,''),Min,Max,Bls0) =>
 1115    check_height(Bls0,Min,Max).
 1116check_rbtree(red(L,K,_,R),Min,Max,Bls) =>
 1117    check_val(K,Min,Max),
 1118    check_red_child(L),
 1119    check_red_child(R),
 1120    check_rbtree(L,Min,K,Bls),
 1121    check_rbtree(R,K,Max,Bls).
 1122check_rbtree(black(L,K,_,R),Min,Max,Bls0) =>
 1123    check_val(K,Min,Max),
 1124    Bls is Bls0-1,
 1125    check_rbtree(L,Min,K,Bls),
 1126    check_rbtree(R,K,Max,Bls).
 1127
 1128check_height(0,_,_) => true.
 1129check_height(Bls0,Min,Max) =>
 1130    throw(error(rbtree(balance(Bls0, Min, Max)), _)).
 1131
 1132check_val(K, Min, Max), (K @> Min ; Min == -inf), (K @< Max ; Max == +inf) =>
 1133    true.
 1134check_val(K, Min, Max) =>
 1135    throw(error(rbtree(order(K, Min, Max)), _)).
 1136
 1137check_red_child(black(_,_,_,_)) => true.
 1138check_red_child(Node), Node = red(_,_,_,_) =>
 1139    domain_error(rb_black, Node).
 1140
 1141
 1142		 /*******************************
 1143		 *            MESSAGES		*
 1144		 *******************************/
 1145
 1146:- multifile
 1147    prolog:error_message//1. 1148
 1149prolog:error_message(rbtree(balance(Bls0, Min, Max))) -->
 1150    [ 'Unbalance ~d between ~w and ~w'-[Bls0,Min,Max] ].
 1151prolog:error_message(rbtree(order(K, Min, Max))) -->
 1152    [ 'not ordered: ~w not between ~w and ~w'-[K,Min,Max] ]