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:- meta_predicate apply(+,?,2,-).  332%apply(black('',_,_,''), _, _, _) :- !, fail.
  333apply(black(Left,Key0,Val0,Right), Key, Goal,
  334      black(NewLeft,Key0,Val,NewRight)) :-
  335    Left \= [],
  336    compare(Cmp,Key0,Key),
  337    (   Cmp == (=)
  338    ->  NewLeft = Left,
  339        NewRight = Right,
  340        call(Goal,Val0,Val)
  341    ;   Cmp == (>)
  342    ->  NewRight = Right,
  343        Val = Val0,
  344        apply(Left, Key, Goal, NewLeft)
  345    ;   NewLeft = Left,
  346        Val = Val0,
  347        apply(Right, Key, Goal, NewRight)
  348    ).
  349apply(red(Left,Key0,Val0,Right), Key, Goal,
  350      red(NewLeft,Key0,Val,NewRight)) :-
  351    compare(Cmp,Key0,Key),
  352    (   Cmp == (=)
  353    ->  NewLeft = Left,
  354        NewRight = Right,
  355        call(Goal,Val0,Val)
  356    ;   Cmp == (>)
  357    ->  NewRight = Right,
  358        Val = Val0,
  359        apply(Left, Key, Goal, NewLeft)
  360    ;   NewLeft = Left,
  361        Val = Val0,
  362        apply(Right, Key, Goal, NewRight)
  363    ).
  364
  365%!  rb_in(?Key, ?Value, +Tree) is nondet.
  366%
  367%   True when Key-Value is a key-value pair in red-black tree Tree. Same
  368%   as below, but does not materialize the pairs.
  369%
  370%        rb_visit(Tree, Pairs), member(Key-Value, Pairs)
  371%
  372%   Leaves a choicepoint  even  if  Key   is  instantiated;  to  avoid a
  373%   choicepoint, use rb_lookup/3.
  374
  375rb_in(Key, Val, t(_,T)) =>
  376    enum(Key, Val, T).
  377
  378enum(Key, Val, black(L,K,V,R)) =>
  379    L \= '',
  380    enum_cases(Key, Val, L, K, V, R).
  381enum(Key, Val, red(L,K,V,R)) =>
  382    enum_cases(Key, Val, L, K, V, R).
  383enum(_Key, _Val, _Tree) => fail.
  384
  385enum_cases(Key, Val, L, _, _, _) :-
  386    enum(Key, Val, L).
  387enum_cases(Key, Val, _, Key, Val, _).
  388enum_cases(Key, Val, _, _, _, R) :-
  389    enum(Key, Val, R).
  390
  391
  392
  393                 /*******************************
  394                 *       TREE INSERTION         *
  395                 *******************************/
  396
  397% We don't use parent nodes, so we may have to fix the root.
  398
  399%!  rb_insert(+Tree, +Key, ?Value, -NewTree) is det.
  400%
  401%   Add an element with key Key and Value   to  the tree Tree creating a
  402%   new red-black tree NewTree. If Key is  a key in Tree, the associated
  403%   value is replaced by Value.  See   also  rb_insert_new/4. Does _not_
  404%   validate that Key is sufficiently instantiated   to  ensure the tree
  405%   remains valid if a key is further instantiated.
  406
  407:- det(rb_insert/4).  408rb_insert(t(Nil,Tree0),Key,Val,NewTree) =>
  409    NewTree = t(Nil,Tree),
  410    insert(Tree0,Key,Val,Nil,Tree).
  411
  412
  413insert(Tree0,Key,Val,Nil,Tree) :-
  414    insert2(Tree0,Key,Val,Nil,TreeI,_),
  415    fix_root(TreeI,Tree).
  416
  417%
  418% Cormen et al present the algorithm as
  419% (1) standard tree insertion;
  420% (2) from the viewpoint of the newly inserted node:
  421%     partially fix the tree;
  422%     move upwards
  423% until reaching the root.
  424%
  425% We do it a little bit different:
  426%
  427% (1) standard tree insertion;
  428% (2) move upwards:
  429%      when reaching a black node;
  430%        if the tree below may be broken, fix it.
  431% We take advantage of Prolog unification
  432% to do several operations in a single go.
  433%
  434
  435
  436
  437%
  438% actual insertion
  439%
  440insert2(black('',_,_,''), K, V, Nil, T, Status) =>
  441    T = red(Nil,K,V,Nil),
  442    Status = not_done.
  443insert2(red(L,K0,V0,R), K, V, Nil, NT, Flag) =>
  444    (   K @< K0
  445    ->  NT = red(NL,K0,V0,R),
  446        insert2(L, K, V, Nil, NL, Flag)
  447    ;   K == K0
  448    ->  NT = red(L,K0,V,R),
  449        Flag = done
  450    ;   NT = red(L,K0,V0,NR),
  451        insert2(R, K, V, Nil, NR, Flag)
  452    ).
  453insert2(black(L,K0,V0,R), K, V, Nil, NT, Flag) =>
  454    (   K @< K0
  455    ->  insert2(L, K, V, Nil, IL, Flag0),
  456        fix_left(Flag0, black(IL,K0,V0,R), NT, Flag)
  457    ;   K == K0
  458    ->  NT = black(L,K0,V,R),
  459        Flag = done
  460    ;   insert2(R, K, V, Nil, IR, Flag0),
  461        fix_right(Flag0, black(L,K0,V0,IR), NT, Flag)
  462    ).
  463
  464% We don't use parent nodes, so we may have to fix the root.
  465
  466%!  rb_insert_new(+Tree, +Key, ?Value, -NewTree) is semidet.
  467%
  468%   Add a new element with key Key and Value to the tree Tree creating a
  469%   new red-black tree NewTree. Fails if  Key   is  a  key in Tree. Does
  470%   _not_ validate that Key is sufficiently   instantiated to ensure the
  471%   tree remains valid if a key is further instantiated.
  472
  473rb_insert_new(t(Nil,Tree0),Key,Val,NewTree) =>
  474    NewTree = t(Nil,Tree),
  475    insert_new(Tree0,Key,Val,Nil,Tree).
  476
  477insert_new(Tree0,Key,Val,Nil,Tree) :-
  478    insert_new_2(Tree0,Key,Val,Nil,TreeI,_),
  479    fix_root(TreeI,Tree).
  480
  481%
  482% actual insertion, copied from insert2
  483%
  484insert_new_2(black('',_,_,''), K, V, Nil, T, Status) =>
  485    T = red(Nil,K,V,Nil),
  486    Status = not_done.
  487insert_new_2(red(L,K0,V0,R), K, V, Nil, NT, Flag) =>
  488    (   K @< K0
  489    ->  NT = red(NL,K0,V0,R),
  490        insert_new_2(L, K, V, Nil, NL, Flag)
  491    ;   K == K0
  492    ->  fail
  493    ;   NT = red(L,K0,V0,NR),
  494        insert_new_2(R, K, V, Nil, NR, Flag)
  495    ).
  496insert_new_2(black(L,K0,V0,R), K, V, Nil, NT, Flag) =>
  497    (   K @< K0
  498    ->  insert_new_2(L, K, V, Nil, IL, Flag0),
  499        fix_left(Flag0, black(IL,K0,V0,R), NT, Flag)
  500    ;   K == K0
  501    ->  fail
  502    ;   insert_new_2(R, K, V, Nil, IR, Flag0),
  503        fix_right(Flag0, black(L,K0,V0,IR), NT, Flag)
  504    ).
  505
  506%
  507% make sure the root is always black.
  508%
  509:- det(fix_root/2).  510fix_root(black(L,K,V,R), Root) => Root = black(L,K,V,R).
  511fix_root(red(L,K,V,R), Root) => Root = black(L,K,V,R).
  512
  513%
  514% How to fix if we have inserted on the left
  515%
  516:- det(fix_left/4).  517fix_left(done,T0,T,Done) => T = T0, Done = done.
  518fix_left(not_done,Tmp,Final,Done) =>
  519    fix_left(Tmp,Final,Done).
  520
  521:- det(fix_left/3).  522%
  523% case 1 of RB: just need to change colors.
  524%
  525fix_left(black(red(Al,AK,AV,red(Be,BK,BV,Ga)),KC,VC,red(De,KD,VD,Ep)),
  526        red(black(Al,AK,AV,red(Be,BK,BV,Ga)),KC,VC,black(De,KD,VD,Ep)),
  527        not_done) :- !.
  528fix_left(black(red(red(Al,KA,VA,Be),KB,VB,Ga),KC,VC,red(De,KD,VD,Ep)),
  529        red(black(red(Al,KA,VA,Be),KB,VB,Ga),KC,VC,black(De,KD,VD,Ep)),
  530        not_done) :- !.
  531%
  532% case 2 of RB: got a knee so need to do rotations
  533%
  534fix_left(black(red(Al,KA,VA,red(Be,KB,VB,Ga)),KC,VC,De),
  535        black(red(Al,KA,VA,Be),KB,VB,red(Ga,KC,VC,De)),
  536        done) :- !.
  537%
  538% case 3 of RB: got a line
  539%
  540fix_left(black(red(red(Al,KA,VA,Be),KB,VB,Ga),KC,VC,De),
  541        black(red(Al,KA,VA,Be),KB,VB,red(Ga,KC,VC,De)),
  542        done) :- !.
  543%
  544% case 4 of RB: nothing to do
  545%
  546fix_left(T,T,done).
  547
  548%
  549% How to fix if we have inserted on the right
  550%
  551:- det(fix_right/4).  552fix_right(done,T0,T,Done) => T0 = T, Done = done.
  553fix_right(not_done,Tmp,Final,Done) =>
  554    fix_right(Tmp,Final,Done).
  555
  556:- det(fix_right/3).  557%
  558% case 1 of RB: just need to change colors.
  559%
  560fix_right(black(red(Ep,KD,VD,De),KC,VC,red(red(Ga,KB,VB,Be),KA,VA,Al)),
  561          red(black(Ep,KD,VD,De),KC,VC,black(red(Ga,KB,VB,Be),KA,VA,Al)),
  562          not_done) :- !.
  563fix_right(black(red(Ep,KD,VD,De),KC,VC,red(Ga,Ka,Va,red(Be,KB,VB,Al))),
  564          red(black(Ep,KD,VD,De),KC,VC,black(Ga,Ka,Va,red(Be,KB,VB,Al))),
  565          not_done) :- !.
  566%
  567% case 2 of RB: got a knee so need to do rotations
  568%
  569fix_right(black(De,KC,VC,red(red(Ga,KB,VB,Be),KA,VA,Al)),
  570          black(red(De,KC,VC,Ga),KB,VB,red(Be,KA,VA,Al)),
  571          done) :- !.
  572%
  573% case 3 of RB: got a line
  574%
  575fix_right(black(De,KC,VC,red(Ga,KB,VB,red(Be,KA,VA,Al))),
  576          black(red(De,KC,VC,Ga),KB,VB,red(Be,KA,VA,Al)),
  577          done) :- !.
  578%
  579% case 4 of RB: nothing to do.
  580%
  581fix_right(T,T,done).
  582
  583
  584%!  rb_delete(+Tree, +Key, -NewTree).
  585%
  586%   Delete element with key Key from the  tree Tree, returning the value
  587%   Val associated with the key and a new  tree NewTree. Fails if Key is
  588%   not in Tree  (using  (==)/2).
  589%
  590%   @see rb_in/3 for backtracking over keys.
  591
  592rb_delete(t(Nil,T), K, NewTree) =>
  593    NewTree = t(Nil,NT),
  594    delete(T, K, _, NT, _).
  595
  596%!  rb_delete(+Tree, +Key, -Val, -NewTree).
  597%
  598%   Same as rb_delete(Tree, Key, NewTree), but also unifies Val with the
  599%   value associated with Key in Tree.
  600
  601rb_delete(t(Nil,T), K, V, NewTree) =>
  602    NewTree = t(Nil,NT),
  603    delete(T, K, V0, NT, _),
  604    V = V0.
  605
  606%
  607% I am afraid our representation is not as nice for delete
  608%
  609delete(red(L,K0,V0,R), K, V, NT, Flag) =>
  610    delete_red(L,K0,V0,R, K, V, NT, Flag).
  611delete(black(L,K0,V0,R), K, V, NT, Flag) =>
  612    delete_black(L,K0,V0,R, K, V, NT, Flag).
  613delete('', _K, _V, _NT, _Flag) =>
  614    fail.
  615
  616delete_red(L,K0,V0,R, K, V, NT, Flag), K @< K0 =>
  617    delete(L, K, V, NL, Flag0),
  618    fixup_left(Flag0,red(NL,K0,V0,R),NT, Flag).
  619delete_red(L,K0,V0,R, K, V, NT, Flag), K @> K0 =>
  620    delete(R, K, V, NR, Flag0),
  621    fixup_right(Flag0,red(L,K0,V0,NR),NT, Flag).
  622delete_red(L,_,V0,R, _, V, Out, Flag) => % K == K0,
  623    V0 = V,
  624    delete_red_node(L,R,Out,Flag).
  625
  626delete_black(L,K0,V0,R, K, V, NT, Flag), K @< K0 =>
  627    delete(L, K, V, NL, Flag0),
  628    fixup_left(Flag0,black(NL,K0,V0,R),NT, Flag).
  629delete_black(L,K0,V0,R, K, V, NT, Flag), K @> K0 =>
  630    delete(R, K, V, NR, Flag0),
  631    fixup_right(Flag0,black(L,K0,V0,NR),NT, Flag).
  632delete_black(L,_,V0,R, _, V, Out, Flag) => % K == K0,
  633    V0 = V,
  634    delete_black_node(L,R,Out,Flag).
  635
  636%!  rb_del_min(+Tree, -Key, -Val, -NewTree)
  637%
  638%   Delete the least element from the tree  Tree, returning the key Key,
  639%   the value Val associated with the key  and a new tree NewTree. Fails
  640%   if Tree is empty.
  641
  642rb_del_min(t(Nil,T), K, Val, NewTree) =>
  643    NewTree = t(Nil,NT),
  644    del_min(T, K, Val, Nil, NT, _).
  645
  646del_min(red(black('',_,_,_),K,V,R), K, V, Nil, Out, Flag) :-
  647    !,
  648    delete_red_node(Nil,R,Out,Flag).
  649del_min(red(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  650    del_min(L, K, V, Nil, NL, Flag0),
  651    fixup_left(Flag0,red(NL,K0,V0,R), NT, Flag).
  652del_min(black(black('',_,_,_),K,V,R), K, V, Nil, Out, Flag) :-
  653    !,
  654    delete_black_node(Nil,R,Out,Flag).
  655del_min(black(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  656    del_min(L, K, V, Nil, NL, Flag0),
  657    fixup_left(Flag0,black(NL,K0,V0,R),NT, Flag).
  658
  659
  660%!  rb_del_max(+Tree, -Key, -Val, -NewTree)
  661%
  662%   Delete the largest element from  the   tree  Tree, returning the key
  663%   Key, the value Val associated with the   key and a new tree NewTree.
  664%   Fails if Tree is empty.
  665
  666rb_del_max(t(Nil,T), K, Val, NewTree) =>
  667    NewTree = t(Nil,NT),
  668    del_max(T, K, Val, Nil, NT, _).
  669
  670del_max(red(L,K,V,black('',_,_,_)), K, V, Nil, Out, Flag) :-
  671    !,
  672    delete_red_node(L,Nil,Out,Flag).
  673del_max(red(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  674    del_max(R, K, V, Nil, NR, Flag0),
  675    fixup_right(Flag0,red(L,K0,V0,NR),NT, Flag).
  676del_max(black(L,K,V,black('',_,_,_)), K, V, Nil, Out, Flag) :-
  677    !,
  678    delete_black_node(L,Nil,Out,Flag).
  679del_max(black(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  680    del_max(R, K, V, Nil, NR, Flag0),
  681    fixup_right(Flag0,black(L,K0,V0,NR), NT, Flag).
  682
  683delete_red_node(L1,L2,L1,done) :- L1 == L2, !.
  684delete_red_node(black('',_,_,''),R,R,done) :-  !.
  685delete_red_node(L,black('',_,_,''),L,done) :-  !.
  686delete_red_node(L,R,Out,Done) :-
  687    delete_next(R,NK,NV,NR,Done0),
  688    fixup_right(Done0,red(L,NK,NV,NR),Out,Done).
  689
  690delete_black_node(L1,L2,L1,not_done) :-         L1 == L2, !.
  691delete_black_node(black('',_,_,''),red(L,K,V,R),black(L,K,V,R),done) :- !.
  692delete_black_node(black('',_,_,''),R,R,not_done) :- !.
  693delete_black_node(red(L,K,V,R),black('',_,_,''),black(L,K,V,R),done) :- !.
  694delete_black_node(L,black('',_,_,''),L,not_done) :- !.
  695delete_black_node(L,R,Out,Done) :-
  696    delete_next(R,NK,NV,NR,Done0),
  697    fixup_right(Done0,black(L,NK,NV,NR),Out,Done).
  698
  699delete_next(red(black('',_,_,''),K,V,R),K,V,R,done) :-  !.
  700delete_next(black(black('',_,_,''),K,V,red(L1,K1,V1,R1)),
  701        K,V,black(L1,K1,V1,R1),done) :- !.
  702delete_next(black(black('',_,_,''),K,V,R),K,V,R,not_done) :- !.
  703delete_next(red(L,K,V,R),K0,V0,Out,Done) :-
  704    delete_next(L,K0,V0,NL,Done0),
  705    fixup_left(Done0,red(NL,K,V,R),Out,Done).
  706delete_next(black(L,K,V,R),K0,V0,Out,Done) :-
  707    delete_next(L,K0,V0,NL,Done0),
  708    fixup_left(Done0,black(NL,K,V,R),Out,Done).
  709
  710fixup_left(done,T,T,done).
  711fixup_left(not_done,T,NT,Done) :-
  712    fixup2(T,NT,Done).
  713
  714%
  715% case 1: x moves down, so we have to try to fix it again.
  716% case 1 -> 2,3,4 -> done
  717%
  718fixup2(black(black(Al,KA,VA,Be),KB,VB,
  719             red(black(Ga,KC,VC,De),KD,VD,
  720                 black(Ep,KE,VE,Fi))),
  721        black(T1,KD,VD,black(Ep,KE,VE,Fi)),done) :-
  722    !,
  723    fixup2(red(black(Al,KA,VA,Be),KB,VB,black(Ga,KC,VC,De)),
  724            T1,
  725            _).
  726%
  727% case 2: x moves up, change one to red
  728%
  729fixup2(red(black(Al,KA,VA,Be),KB,VB,
  730           black(black(Ga,KC,VC,De),KD,VD,
  731                 black(Ep,KE,VE,Fi))),
  732        black(black(Al,KA,VA,Be),KB,VB,
  733              red(black(Ga,KC,VC,De),KD,VD,
  734                  black(Ep,KE,VE,Fi))),done) :- !.
  735fixup2(black(black(Al,KA,VA,Be),KB,VB,
  736             black(black(Ga,KC,VC,De),KD,VD,
  737                   black(Ep,KE,VE,Fi))),
  738        black(black(Al,KA,VA,Be),KB,VB,
  739              red(black(Ga,KC,VC,De),KD,VD,
  740                  black(Ep,KE,VE,Fi))),not_done) :- !.
  741%
  742% case 3: x stays put, shift left and do a 4
  743%
  744fixup2(red(black(Al,KA,VA,Be),KB,VB,
  745           black(red(Ga,KC,VC,De),KD,VD,
  746                 black(Ep,KE,VE,Fi))),
  747        red(black(black(Al,KA,VA,Be),KB,VB,Ga),KC,VC,
  748            black(De,KD,VD,black(Ep,KE,VE,Fi))),
  749        done) :- !.
  750fixup2(black(black(Al,KA,VA,Be),KB,VB,
  751             black(red(Ga,KC,VC,De),KD,VD,
  752                   black(Ep,KE,VE,Fi))),
  753        black(black(black(Al,KA,VA,Be),KB,VB,Ga),KC,VC,
  754              black(De,KD,VD,black(Ep,KE,VE,Fi))),
  755        done) :- !.
  756%
  757% case 4: rotate left, get rid of red
  758%
  759fixup2(red(black(Al,KA,VA,Be),KB,VB,
  760           black(C,KD,VD,red(Ep,KE,VE,Fi))),
  761        red(black(black(Al,KA,VA,Be),KB,VB,C),KD,VD,
  762            black(Ep,KE,VE,Fi)),
  763        done).
  764fixup2(black(black(Al,KA,VA,Be),KB,VB,
  765             black(C,KD,VD,red(Ep,KE,VE,Fi))),
  766       black(black(black(Al,KA,VA,Be),KB,VB,C),KD,VD,
  767             black(Ep,KE,VE,Fi)),
  768       done).
  769
  770fixup_right(done,T,T,done).
  771fixup_right(not_done,T,NT,Done) :-
  772    fixup3(T,NT,Done).
  773
  774% case 1: x moves down, so we have to try to fix it again.
  775% case 1 -> 2,3,4 -> done
  776%
  777fixup3(black(red(black(Fi,KE,VE,Ep),KD,VD,
  778                 black(De,KC,VC,Ga)),KB,VB,
  779             black(Be,KA,VA,Al)),
  780        black(black(Fi,KE,VE,Ep),KD,VD,T1),done) :-
  781    !,
  782    fixup3(red(black(De,KC,VC,Ga),KB,VB,
  783               black(Be,KA,VA,Al)),T1,_).
  784
  785%
  786% case 2: x moves up, change one to red
  787%
  788fixup3(red(black(black(Fi,KE,VE,Ep),KD,VD,
  789                 black(De,KC,VC,Ga)),KB,VB,
  790           black(Be,KA,VA,Al)),
  791       black(red(black(Fi,KE,VE,Ep),KD,VD,
  792                 black(De,KC,VC,Ga)),KB,VB,
  793             black(Be,KA,VA,Al)),
  794       done) :- !.
  795fixup3(black(black(black(Fi,KE,VE,Ep),KD,VD,
  796                   black(De,KC,VC,Ga)),KB,VB,
  797             black(Be,KA,VA,Al)),
  798       black(red(black(Fi,KE,VE,Ep),KD,VD,
  799                 black(De,KC,VC,Ga)),KB,VB,
  800             black(Be,KA,VA,Al)),
  801       not_done):- !.
  802%
  803% case 3: x stays put, shift left and do a 4
  804%
  805fixup3(red(black(black(Fi,KE,VE,Ep),KD,VD,
  806                 red(De,KC,VC,Ga)),KB,VB,
  807           black(Be,KA,VA,Al)),
  808       red(black(black(Fi,KE,VE,Ep),KD,VD,De),KC,VC,
  809           black(Ga,KB,VB,black(Be,KA,VA,Al))),
  810       done) :- !.
  811fixup3(black(black(black(Fi,KE,VE,Ep),KD,VD,
  812                   red(De,KC,VC,Ga)),KB,VB,
  813             black(Be,KA,VA,Al)),
  814       black(black(black(Fi,KE,VE,Ep),KD,VD,De),KC,VC,
  815             black(Ga,KB,VB,black(Be,KA,VA,Al))),
  816       done) :- !.
  817%
  818% case 4: rotate right, get rid of red
  819%
  820fixup3(red(black(red(Fi,KE,VE,Ep),KD,VD,C),KB,VB,black(Be,KA,VA,Al)),
  821       red(black(Fi,KE,VE,Ep),KD,VD,black(C,KB,VB,black(Be,KA,VA,Al))),
  822       done).
  823fixup3(black(black(red(Fi,KE,VE,Ep),KD,VD,C),KB,VB,black(Be,KA,VA,Al)),
  824       black(black(Fi,KE,VE,Ep),KD,VD,black(C,KB,VB,black(Be,KA,VA,Al))),
  825       done).
  826
  827%!  rb_visit(+Tree, -Pairs) is det.
  828%
  829%   Pairs is an infix visit of tree Tree, where each element of Pairs is
  830%   of the form Key-Value.
  831
  832:- det(rb_visit/2).  833rb_visit(t(_,T),Lf) =>
  834    visit(T,[],Lf).
  835
  836visit(black('',_,_,_),L0,L) => L0 = L.
  837visit(red(L,K,V,R),L0,Lf) =>
  838    visit(L,[K-V|L1],Lf),
  839    visit(R,L0,L1).
  840visit(black(L,K,V,R),L0,Lf) =>
  841    visit(L,[K-V|L1],Lf),
  842    visit(R,L0,L1).
  843
  844:- meta_predicate map(?,2,?,?).  % this is required.
  845
  846%!  rb_map(+Tree, :G, -NewTree) is semidet.
  847%
  848%   For all nodes Key in the tree Tree, if the value associated with key
  849%   Key is Val0 in tree Tree, and   if call(G,Val0,ValF) holds, then the
  850%   value  associated  with  Key  in   NewTree    is   ValF.   Fails  if
  851%   call(G,Val0,ValF)  is  not  satisfiable  for  all   Val0.  If  G  is
  852%   non-deterministic, rb_map/3 will backtrack over  all possible values
  853%   from call(G,Val0,ValF). You should not depend   on the order of tree
  854%   traversal (currently: key order).
  855
  856rb_map(t(Nil,Tree),Goal,NewTree2) =>
  857    NewTree2 = t(Nil,NewTree),
  858    map(Tree,Goal,NewTree,Nil).
  859
  860
  861map(black('',_,_,''),_,Nil0,Nil) => Nil0 = Nil.
  862map(red(L,K,V,R),Goal,NewTree,Nil) =>
  863    NewTree = red(NL,K,NV,NR),
  864    call(Goal,V,NV),
  865    map(L,Goal,NL,Nil),
  866    map(R,Goal,NR,Nil).
  867map(black(L,K,V,R),Goal,NewTree,Nil) =>
  868    NewTree = black(NL,K,NV,NR),
  869    call(Goal,V,NV),
  870    map(L,Goal,NL,Nil),
  871    map(R,Goal,NR,Nil).
  872
  873:- meta_predicate map(?,1).  % this is required.
  874
  875%!  rb_map(+T, :Goal) is semidet.
  876%
  877%   True if call(Goal, Value) is true for all nodes in T.
  878
  879rb_map(t(_,Tree),Goal) =>
  880    map(Tree,Goal).
  881
  882
  883map(black('',_,_,''),_) => true.
  884map(red(L,_,V,R),Goal) =>
  885    call(Goal,V),
  886    map(L,Goal),
  887    map(R,Goal).
  888map(black(L,_,V,R),Goal) =>
  889    call(Goal,V),
  890    map(L,Goal),
  891    map(R,Goal).
  892
  893%!  rb_fold(:Goal, +Tree, +State0, -State).
  894%
  895%   Fold the given predicate  over  all   the  key-value  pairs in Tree,
  896%   starting with initial state State0  and   returning  the final state
  897%   State. Pred is called as
  898%
  899%       call(Pred, Key-Value, State1, State2)
  900%
  901%   Determinism depends on Goal.
  902
  903rb_fold(Pred, t(_,T), S1, S2) =>
  904    fold(T, Pred, S1, S2).
  905
  906fold(black(L,K,V,R), Pred) -->
  907    (   {L == ''}
  908    ->  []
  909    ;   fold_parts(Pred, L, K-V, R)
  910    ).
  911fold(red(L,K,V,R), Pred) -->
  912    fold_parts(Pred, L, K-V, R).
  913
  914fold_parts(Pred, L, KV, R) -->
  915    fold(L, Pred),
  916    call(Pred, KV),
  917    fold(R, Pred).
  918
  919%!  rb_clone(+TreeIn, -TreeOut, -Pairs) is det.
  920%
  921%   `Clone' the red-back tree TreeIn into a   new  tree TreeOut with the
  922%   same keys as the original but with all values set to unbound values.
  923%   Pairs is a list containing all new nodes as pairs K-V.
  924
  925:- det(rb_clone/3).  926rb_clone(t(Nil,T),TreeOut,Ns) =>
  927    TreeOut = t(Nil,NT),
  928    clone(T,Nil,NT,Ns,[]).
  929
  930clone(black('',_,_,''),Nil0,Nil,Ns0,Ns) => Nil0=Nil, Ns0=Ns.
  931clone(red(L,K,_,R),Nil,TreeOut,NsF,Ns0) =>
  932    TreeOut = red(NL,K,NV,NR),
  933    clone(L,Nil,NL,NsF,[K-NV|Ns1]),
  934    clone(R,Nil,NR,Ns1,Ns0).
  935clone(black(L,K,_,R),Nil,TreeOut,NsF,Ns0) =>
  936    TreeOut = black(NL,K,NV,NR),
  937    clone(L,Nil,NL,NsF,[K-NV|Ns1]),
  938    clone(R,Nil,NR,Ns1,Ns0).
  939
  940%!  rb_partial_map(+Tree, +Keys, :G, -NewTree)
  941%
  942%   For all nodes Key in Keys, if the   value associated with key Key is
  943%   Val0 in tree Tree, and if   call(G,Val0,ValF)  holds, then the value
  944%   associated with Key in NewTree is ValF,   otherwise  it is the value
  945%   associated with the key in Tree. Fails if   Key  isn't in Tree or if
  946%   call(G,Val0,ValF) is not satisfiable for all   Val0 in Keys. Assumes
  947%   keys are sorted and not repeated (fails if this is not true).
  948
  949rb_partial_map(t(Nil,T0), Map, Goal, NewTree) =>
  950    NewTree = t(Nil,TF),
  951    partial_map(T0, Map, [], Nil, Goal, TF).
  952
  953partial_map(T,[],[],_,_,T) :- !.
  954partial_map(black('',_,_,_),Map,Map,Nil,_,Nil) :- !.
  955partial_map(red(L,K,V,R),Map,MapF,Nil,Goal,red(NL,K,NV,NR)) :-
  956    partial_map(L,Map,MapI,Nil,Goal,NL),
  957    (   MapI == []
  958    ->  NR = R, NV = V, MapF = []
  959    ;   MapI = [K1|MapR],
  960        (   K == K1
  961        ->  (   call(Goal,V,NV)
  962            ->  true
  963            ;   NV = V
  964            ),
  965            MapN = MapR
  966        ;   NV = V,
  967            MapN = MapI
  968        ),
  969        partial_map(R,MapN,MapF,Nil,Goal,NR)
  970    ).
  971partial_map(black(L,K,V,R),Map,MapF,Nil,Goal,black(NL,K,NV,NR)) :-
  972    partial_map(L,Map,MapI,Nil,Goal,NL),
  973    (   MapI == []
  974    ->  NR = R, NV = V, MapF = []
  975    ;   MapI = [K1|MapR],
  976        (   K == K1
  977        ->  (   call(Goal,V,NV)
  978            ->  true
  979            ;   NV = V
  980            ),
  981            MapN = MapR
  982        ;   NV = V,
  983            MapN = MapI
  984        ),
  985        partial_map(R,MapN,MapF,Nil,Goal,NR)
  986    ).
  987
  988
  989%!  rb_keys(+Tree, -Keys) is det.
  990%
  991%   Keys is unified with an ordered list   of  all keys in the Red-Black
  992%   tree Tree.
  993
  994:- det(rb_keys/2).  995rb_keys(t(_,T),Lf) =>
  996    keys(T,[],Lf).
  997
  998keys(black('',_,_,''),L0,L) => L0 = L.
  999keys(red(L,K,_,R),L0,Lf) =>
 1000    keys(L,[K|L1],Lf),
 1001    keys(R,L0,L1).
 1002keys(black(L,K,_,R),L0,Lf) =>
 1003    keys(L,[K|L1],Lf),
 1004    keys(R,L0,L1).
 1005
 1006
 1007%!  list_to_rbtree(+List, -Tree) is det.
 1008%
 1009%   Tree is the red-black tree  corresponding   to  the mapping in List,
 1010%   which should be a list of Key-Value   pairs. List should not contain
 1011%   more than one entry for each distinct key, but this is not validated
 1012%   by list_to_rbtree/2.
 1013
 1014:- det(list_to_rbtree/2). 1015list_to_rbtree(List, T) :-
 1016    sort(List,Sorted),
 1017    ord_list_to_rbtree(Sorted, T).
 1018
 1019%!  ord_list_to_rbtree(+List, -Tree) is det.
 1020%
 1021%   Tree is the red-black tree  corresponding   to  the  mapping in list
 1022%   List, which should be a list  of   Key-Value  pairs. List should not
 1023%   contain more than one entry for each   distinct key, but this is not
 1024%   validated by ord_list_to_rbtree/2. List is assumed
 1025%   to be sorted according to the standard order of terms.
 1026
 1027:- det(ord_list_to_rbtree/2). 1028ord_list_to_rbtree([], Tree) =>
 1029    Tree = t(Nil,Nil),
 1030    Nil = black('', _, _, '').
 1031ord_list_to_rbtree([K-V], Tree) =>
 1032    Tree = t(Nil,black(Nil,K,V,Nil)),
 1033    Nil = black('', _, _, '').
 1034ord_list_to_rbtree(List, Tree2) =>
 1035    Tree2 = t(Nil,Tree),
 1036    Nil = black('', _, _, ''),
 1037    Ar =.. [seq|List],
 1038    functor(Ar,_,L),
 1039    Height is truncate(log(L)/log(2)),
 1040    construct_rbtree(1, L, Ar, Height, Nil, Tree).
 1041
 1042construct_rbtree(L, M, _, _, Nil, Nil) :- M < L, !.
 1043construct_rbtree(L, L, Ar, Depth, Nil, Node) :-
 1044    !,
 1045    arg(L, Ar, K-Val),
 1046    build_node(Depth, Nil, K, Val, Nil, Node).
 1047construct_rbtree(I0, Max, Ar, Depth, Nil, Node) :-
 1048    I is (I0+Max)//2,
 1049    arg(I, Ar, K-Val),
 1050    build_node(Depth, Left, K, Val, Right, Node),
 1051    I1 is I-1,
 1052    NewDepth is Depth-1,
 1053    construct_rbtree(I0, I1, Ar, NewDepth, Nil, Left),
 1054    I2 is I+1,
 1055    construct_rbtree(I2, Max, Ar, NewDepth, Nil, Right).
 1056
 1057build_node( 0, Left, K, Val, Right, red(Left, K, Val, Right)) :- !.
 1058build_node( _, Left, K, Val, Right, black(Left, K, Val, Right)).
 1059
 1060
 1061%!  rb_size(+Tree, -Size) is det.
 1062%
 1063%   Size is the number of elements in Tree.
 1064
 1065:- det(rb_size/2). 1066rb_size(t(_,T),Size) =>
 1067    size(T,0,Size).
 1068
 1069size(black('',_,_,_),Sz,Sz) :- !.
 1070size(red(L,_,_,R),Sz0,Szf) :-
 1071    Sz1 is Sz0+1,
 1072    size(L,Sz1,Sz2),
 1073    size(R,Sz2,Szf).
 1074size(black(L,_,_,R),Sz0,Szf) :-
 1075    Sz1 is Sz0+1,
 1076    size(L,Sz1,Sz2),
 1077    size(R,Sz2,Szf).
 1078
 1079%!  is_rbtree(@Term) is semidet.
 1080%
 1081%   True if Term is a valid Red-Black   tree. Processes the entire tree,
 1082%   checking the coloring of the nodes, the  balance and the ordering of
 1083%   keys.    Does _not_ validate that keys are sufficiently instantiated
 1084%   to ensure the tree remains valid if a key is further instantiated.
 1085
 1086is_rbtree(X), var(X) =>
 1087    fail.
 1088is_rbtree(t(Nil,Nil)) => true.
 1089is_rbtree(t(_,T)) =>
 1090    Err = error(_,_),
 1091    catch(check_rbtree(T), Err, is_rbtree_error(Err)).
 1092is_rbtree(_) =>
 1093    fail.
 1094
 1095is_rbtree_error(Err), Err = error(resource_error(_),_) => throw(Err).
 1096is_rbtree_error(_) => fail.
 1097
 1098% This code checks if a tree is ordered and a rbtree
 1099
 1100check_rbtree(black(L,K,_,R)) =>
 1101    find_path_blacks(L, 0, Bls),
 1102    check_rbtree(L,-inf,K,Bls),
 1103    check_rbtree(R,K,+inf,Bls).
 1104check_rbtree(Node), Node = red(_,_,_,_) =>
 1105    domain_error(rb_black, Node).
 1106
 1107
 1108find_path_blacks(black('',_,_,''), Bls0, Bls) => Bls = Bls0.
 1109find_path_blacks(black(L,_,_,_), Bls0, Bls) =>
 1110    Bls1 is Bls0+1,
 1111    find_path_blacks(L, Bls1, Bls).
 1112find_path_blacks(red(L,_,_,_), Bls0, Bls) =>
 1113    find_path_blacks(L, Bls0, Bls).
 1114
 1115check_rbtree(black('',_,_,''),Min,Max,Bls0) =>
 1116    check_height(Bls0,Min,Max).
 1117check_rbtree(red(L,K,_,R),Min,Max,Bls) =>
 1118    check_val(K,Min,Max),
 1119    check_red_child(L),
 1120    check_red_child(R),
 1121    check_rbtree(L,Min,K,Bls),
 1122    check_rbtree(R,K,Max,Bls).
 1123check_rbtree(black(L,K,_,R),Min,Max,Bls0) =>
 1124    check_val(K,Min,Max),
 1125    Bls is Bls0-1,
 1126    check_rbtree(L,Min,K,Bls),
 1127    check_rbtree(R,K,Max,Bls).
 1128
 1129check_height(0,_,_) => true.
 1130check_height(Bls0,Min,Max) =>
 1131    throw(error(rbtree(balance(Bls0, Min, Max)), _)).
 1132
 1133check_val(K, Min, Max), (K @> Min ; Min == -inf), (K @< Max ; Max == +inf) =>
 1134    true.
 1135check_val(K, Min, Max) =>
 1136    throw(error(rbtree(order(K, Min, Max)), _)).
 1137
 1138check_red_child(black(_,_,_,_)) => true.
 1139check_red_child(Node), Node = red(_,_,_,_) =>
 1140    domain_error(rb_black, Node).
 1141
 1142
 1143		 /*******************************
 1144		 *            MESSAGES		*
 1145		 *******************************/
 1146
 1147:- multifile
 1148    prolog:error_message//1. 1149
 1150prolog:error_message(rbtree(balance(Bls0, Min, Max))) -->
 1151    [ 'Unbalance ~d between ~w and ~w'-[Bls0,Min,Max] ].
 1152prolog:error_message(rbtree(order(K, Min, Max))) -->
 1153    [ 'not ordered: ~w not between ~w and ~w'-[K,Min,Max] ]