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-2017, 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, +T
   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,                % +T0, +Key, ?Value, -NewTree
   43            rb_insert_new/4,            % +T0, +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          ]).

   84:- meta_predicate
   85    rb_map(+,2,-),
   86    rb_map(?,1),
   87    rb_partial_map(+,+,2,-),
   88    rb_apply(+,+,2,-),
   89    rb_fold(3,+,+,-).   90
   91/*
   92:- use_module(library(type_check)).
   93
   94:- type rbtree(K,V) ---> t(tree(K,V),tree(K,V)).
   95:- type tree(K,V)   ---> black(tree(K,V),K,V,tree(K,V))
   96                       ; red(tree(K,V),K,V,tree(K,V))
   97                       ; ''.
   98:- type cmp ---> (=) ; (<) ; (>).
   99
  100
  101:- pred rb_new(rbtree(_K,_V)).
  102:- pred rb_empty(rbtree(_K,_V)).
  103:- pred rb_lookup(K,V,rbtree(K,V)).
  104:- pred lookup(K,V, tree(K,V)).
  105:- pred lookup(cmp, K, V, tree(K,V)).
  106:- pred rb_min(rbtree(K,V),K,V).
  107:- pred min(tree(K,V),K,V).
  108:- pred rb_max(rbtree(K,V),K,V).
  109:- pred max(tree(K,V),K,V).
  110:- pred rb_next(rbtree(K,V),K,pair(K,V),V).
  111:- pred next(tree(K,V),K,pair(K,V),V,tree(K,V)).
  112*/

 rb_new(-Tree) is det

Create a new Red-Black tree Tree.

deprecated

- Use rb_empty/1.

  120rb_new(t(Nil,Nil)) :-
  121    Nil = black('',_,_,'').

 rb_empty(?Tree) is semidet

Succeeds if Tree is an empty Red-Black tree.

  127rb_empty(t(Nil,Nil)) :-
  128    Nil = black('',_,_,'').

 rb_lookup(+Key, -Value, +Tree) is semidet

True when Value is associated with Key in the Red-Black tree Tree. The given Key may include variables, in which case the RB tree is searched for a key with equivalent, as in (==)/2, variables. Time complexity is O(log N) in the number of elements in the tree.

  137rb_lookup(Key, Val, t(_,Tree)) :-
  138    lookup(Key, Val, Tree).
  139
  140lookup(_, _, black('',_,_,'')) :- !, fail.
  141lookup(Key, Val, Tree) :-
  142    arg(2,Tree,KA),
  143    compare(Cmp,KA,Key),
  144    lookup(Cmp,Key,Val,Tree).
  145
  146lookup(>, K, V, Tree) :-
  147    arg(1,Tree,NTree),
  148    lookup(K, V, NTree).
  149lookup(<, K, V, Tree) :-
  150    arg(4,Tree,NTree),
  151    lookup(K, V, NTree).
  152lookup(=, _, V, Tree) :-
  153    arg(3,Tree,V).

 rb_min(+Tree, -Key, -Value) is semidet

Key is the minimum key in Tree, and is associated with Val.

  159rb_min(t(_,Tree), Key, Val) :-
  160    min(Tree, Key, Val).
  161
  162min(red(black('',_,_,_),Key,Val,_), Key, Val) :- !.
  163min(black(black('',_,_,_),Key,Val,_), Key, Val) :- !.
  164min(red(Right,_,_,_), Key, Val) :-
  165    min(Right,Key,Val).
  166min(black(Right,_,_,_), Key, Val) :-
  167    min(Right,Key,Val).

 rb_max(+Tree, -Key, -Value) is semidet

Key is the maximal key in Tree, and is associated with Val.

  173rb_max(t(_,Tree), Key, Val) :-
  174    max(Tree, Key, Val).
  175
  176max(red(_,Key,Val,black('',_,_,_)), Key, Val) :- !.
  177max(black(_,Key,Val,black('',_,_,_)), Key, Val) :- !.
  178max(red(_,_,_,Left), Key, Val) :-
  179    max(Left,Key,Val).
  180max(black(_,_,_,Left), Key, Val) :-
  181    max(Left,Key,Val).

 rb_next(+Tree, +Key, -Next, -Value) is semidet

Next is the next element after Key in Tree, and is associated with Val.

  188rb_next(t(_,Tree), Key, Next, Val) :-
  189    next(Tree, Key, Next, Val, []).
  190
  191next(black('',_,_,''), _, _, _, _) :- !, fail.
  192next(Tree, Key, Next, Val, Candidate) :-
  193    arg(2,Tree,KA),
  194    arg(3,Tree,VA),
  195    compare(Cmp,KA,Key),
  196    next(Cmp, Key, KA, VA, Next, Val, Tree, Candidate).
  197
  198next(>, K, KA, VA, NK, V, Tree, _) :-
  199    arg(1,Tree,NTree),
  200    next(NTree,K,NK,V,KA-VA).
  201next(<, K, _, _, NK, V, Tree, Candidate) :-
  202    arg(4,Tree,NTree),
  203    next(NTree,K,NK,V,Candidate).
  204next(=, _, _, _, NK, Val, Tree, Candidate) :-
  205    arg(4,Tree,NTree),
  206    (   min(NTree, NK, Val)
  207    ->  true
  208    ;   Candidate = (NK-Val)
  209    ).

 rb_previous(+Tree, +Key, -Previous, -Value) is semidet

Previous is the previous element after Key in Tree, and is associated with Val.

  216rb_previous(t(_,Tree), Key, Previous, Val) :-
  217    previous(Tree, Key, Previous, Val, []).
  218
  219previous(black('',_,_,''), _, _, _, _) :- !, fail.
  220previous(Tree, Key, Previous, Val, Candidate) :-
  221    arg(2,Tree,KA),
  222    arg(3,Tree,VA),
  223    compare(Cmp,KA,Key),
  224    previous(Cmp, Key, KA, VA, Previous, Val, Tree, Candidate).
  225
  226previous(>, K, _, _, NK, V, Tree, Candidate) :-
  227    arg(1,Tree,NTree),
  228    previous(NTree,K,NK,V,Candidate).
  229previous(<, K, KA, VA, NK, V, Tree, _) :-
  230    arg(4,Tree,NTree),
  231    previous(NTree,K,NK,V,KA-VA).
  232previous(=, _, _, _, K, Val, Tree, Candidate) :-
  233    arg(1,Tree,NTree),
  234    (   max(NTree, K, Val)
  235    ->  true
  236    ;   Candidate = (K-Val)
  237    ).

 rb_update(+Tree, +Key, +NewVal, -NewTree) is semidet

 rb_update(+Tree, +Key, ?OldVal, +NewVal, -NewTree) is semidet

Tree NewTree is tree Tree, but with value for Key associated with NewVal. Fails if it cannot find Key in Tree.

  245rb_update(t(Nil,OldTree), Key, OldVal, Val, t(Nil,NewTree)) :-
  246    update(OldTree, Key, OldVal, Val, NewTree).
  247
  248rb_update(t(Nil,OldTree), Key, Val, t(Nil,NewTree)) :-
  249    update(OldTree, Key, _, Val, NewTree).
  250
  251update(black(Left,Key0,Val0,Right), Key, OldVal, Val, NewTree) :-
  252    Left \= [],
  253    compare(Cmp,Key0,Key),
  254    (   Cmp == (=)
  255    ->  OldVal = Val0,
  256        NewTree = black(Left,Key0,Val,Right)
  257    ;   Cmp == (>)
  258    ->  NewTree = black(NewLeft,Key0,Val0,Right),
  259        update(Left, Key, OldVal, Val, NewLeft)
  260    ;   NewTree = black(Left,Key0,Val0,NewRight),
  261        update(Right, Key, OldVal, Val, NewRight)
  262    ).
  263update(red(Left,Key0,Val0,Right), Key, OldVal, Val, NewTree) :-
  264    compare(Cmp,Key0,Key),
  265    (   Cmp == (=)
  266    ->  OldVal = Val0,
  267        NewTree = red(Left,Key0,Val,Right)
  268    ;   Cmp == (>)
  269    ->  NewTree = red(NewLeft,Key0,Val0,Right),
  270        update(Left, Key, OldVal, Val, NewLeft)
  271    ;   NewTree = red(Left,Key0,Val0,NewRight),
  272        update(Right, Key, OldVal, Val, NewRight)
  273    ).

 rb_apply(+Tree, +Key, :G, -NewTree) is semidet

If the value associated with key Key is Val0 in Tree, and if call(G,Val0,ValF) holds, then NewTree differs from Tree only in that Key is associated with value ValF in tree NewTree. Fails if it cannot find Key in Tree, or if call(G,Val0,ValF) is not satisfiable.

  282rb_apply(t(Nil,OldTree), Key, Goal, t(Nil,NewTree)) :-
  283    apply(OldTree, Key, Goal, NewTree).
  284
  285%apply(black('',_,_,''), _, _, _) :- !, fail.
  286apply(black(Left,Key0,Val0,Right), Key, Goal,
  287      black(NewLeft,Key0,Val,NewRight)) :-
  288    Left \= [],
  289    compare(Cmp,Key0,Key),
  290    (   Cmp == (=)
  291    ->  NewLeft = Left,
  292        NewRight = Right,
  293        call(Goal,Val0,Val)
  294    ;   Cmp == (>)
  295    ->  NewRight = Right,
  296        Val = Val0,
  297        apply(Left, Key, Goal, NewLeft)
  298    ;   NewLeft = Left,
  299        Val = Val0,
  300        apply(Right, Key, Goal, NewRight)
  301    ).
  302apply(red(Left,Key0,Val0,Right), Key, Goal,
  303      red(NewLeft,Key0,Val,NewRight)) :-
  304    compare(Cmp,Key0,Key),
  305    (   Cmp == (=)
  306    ->  NewLeft = Left,
  307        NewRight = Right,
  308        call(Goal,Val0,Val)
  309    ;   Cmp == (>)
  310    ->  NewRight = Right,
  311        Val = Val0,
  312        apply(Left, Key, Goal, NewLeft)
  313    ;   NewLeft = Left,
  314        Val = Val0,
  315        apply(Right, Key, Goal, NewRight)
  316    ).

 rb_in(?Key, ?Value, +Tree) is nondet

True when Key-Value is a key-value pair in red-black tree Tree. Same as below, but does not materialize the pairs.

rb_visit(Tree, Pairs), member(Key-Value, Pairs)

  325rb_in(Key, Val, t(_,T)) :-
  326    enum(Key, Val, T).
  327
  328enum(Key, Val, black(L,K,V,R)) :-
  329    L \= '',
  330    enum_cases(Key, Val, L, K, V, R).
  331enum(Key, Val, red(L,K,V,R)) :-
  332    enum_cases(Key, Val, L, K, V, R).
  333
  334enum_cases(Key, Val, L, _, _, _) :-
  335    enum(Key, Val, L).
  336enum_cases(Key, Val, _, Key, Val, _).
  337enum_cases(Key, Val, _, _, _, R) :-
  338    enum(Key, Val, R).
  339
  340
  341
  342                 /*******************************
  343                 *       TREE INSERTION         *
  344                 *******************************/
  345
  346% We don't use parent nodes, so we may have to fix the root.

 rb_insert(+Tree, +Key, ?Value, -NewTree) is det

Add an element with key Key and Value to the tree Tree creating a new red-black tree NewTree. If Key is a key in Tree, the associated value is replaced by Value. See also rb_insert_new/4.

  354rb_insert(t(Nil,Tree0),Key,Val,t(Nil,Tree)) :-
  355    insert(Tree0,Key,Val,Nil,Tree).
  356
  357
  358insert(Tree0,Key,Val,Nil,Tree) :-
  359    insert2(Tree0,Key,Val,Nil,TreeI,_),
  360    fix_root(TreeI,Tree).
  361
  362%
  363% Cormen et al present the algorithm as
  364% (1) standard tree insertion;
  365% (2) from the viewpoint of the newly inserted node:
  366%     partially fix the tree;
  367%     move upwards
  368% until reaching the root.
  369%
  370% We do it a little bit different:
  371%
  372% (1) standard tree insertion;
  373% (2) move upwards:
  374%      when reaching a black node;
  375%        if the tree below may be broken, fix it.
  376% We take advantage of Prolog unification
  377% to do several operations in a single go.
  378%
  379
  380
  381
  382%
  383% actual insertion
  384%
  385insert2(black('',_,_,''), K, V, Nil, T, Status) :-
  386    !,
  387    T = red(Nil,K,V,Nil),
  388    Status = not_done.
  389insert2(red(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  390    (   K @< K0
  391    ->  NT = red(NL,K0,V0,R),
  392        insert2(L, K, V, Nil, NL, Flag)
  393    ;   K == K0
  394    ->  NT = red(L,K0,V,R),
  395        Flag = done
  396    ;   NT = red(L,K0,V0,NR),
  397        insert2(R, K, V, Nil, NR, Flag)
  398    ).
  399insert2(black(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  400    (   K @< K0
  401    ->  insert2(L, K, V, Nil, IL, Flag0),
  402        fix_left(Flag0, black(IL,K0,V0,R), NT, Flag)
  403    ;   K == K0
  404    ->  NT = black(L,K0,V,R),
  405        Flag = done
  406    ;   insert2(R, K, V, Nil, IR, Flag0),
  407        fix_right(Flag0, black(L,K0,V0,IR), NT, Flag)
  408    ).
  409
  410% We don't use parent nodes, so we may have to fix the root.

 rb_insert_new(+Tree, +Key, ?Value, -NewTree) is semidet

Add a new element with key Key and Value to the tree Tree creating a new red-black tree NewTree. Fails if Key is a key in Tree.

  417rb_insert_new(t(Nil,Tree0),Key,Val,t(Nil,Tree)) :-
  418    insert_new(Tree0,Key,Val,Nil,Tree).
  419
  420insert_new(Tree0,Key,Val,Nil,Tree) :-
  421    insert_new_2(Tree0,Key,Val,Nil,TreeI,_),
  422    fix_root(TreeI,Tree).
  423
  424%
  425% actual insertion, copied from insert2
  426%
  427insert_new_2(black('',_,_,''), K, V, Nil, T, Status) :-
  428    !,
  429    T = red(Nil,K,V,Nil),
  430    Status = not_done.
  431insert_new_2(red(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  432    (   K @< K0
  433    ->  NT = red(NL,K0,V0,R),
  434        insert_new_2(L, K, V, Nil, NL, Flag)
  435    ;   K == K0
  436    ->  fail
  437    ;   NT = red(L,K0,V0,NR),
  438        insert_new_2(R, K, V, Nil, NR, Flag)
  439    ).
  440insert_new_2(black(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  441    (   K @< K0
  442    ->  insert_new_2(L, K, V, Nil, IL, Flag0),
  443        fix_left(Flag0, black(IL,K0,V0,R), NT, Flag)
  444    ;   K == K0
  445    ->  fail
  446    ;   insert_new_2(R, K, V, Nil, IR, Flag0),
  447        fix_right(Flag0, black(L,K0,V0,IR), NT, Flag)
  448    ).
  449
  450%
  451% make sure the root is always black.
  452%
  453fix_root(black(L,K,V,R),black(L,K,V,R)).
  454fix_root(red(L,K,V,R),black(L,K,V,R)).
  455
  456%
  457% How to fix if we have inserted on the left
  458%
  459fix_left(done,T,T,done) :- !.
  460fix_left(not_done,Tmp,Final,Done) :-
  461    fix_left(Tmp,Final,Done).
  462
  463%
  464% case 1 of RB: just need to change colors.
  465%
  466fix_left(black(red(Al,AK,AV,red(Be,BK,BV,Ga)),KC,VC,red(De,KD,VD,Ep)),
  467        red(black(Al,AK,AV,red(Be,BK,BV,Ga)),KC,VC,black(De,KD,VD,Ep)),
  468        not_done) :- !.
  469fix_left(black(red(red(Al,KA,VA,Be),KB,VB,Ga),KC,VC,red(De,KD,VD,Ep)),
  470        red(black(red(Al,KA,VA,Be),KB,VB,Ga),KC,VC,black(De,KD,VD,Ep)),
  471        not_done) :- !.
  472%
  473% case 2 of RB: got a knee so need to do rotations
  474%
  475fix_left(black(red(Al,KA,VA,red(Be,KB,VB,Ga)),KC,VC,De),
  476        black(red(Al,KA,VA,Be),KB,VB,red(Ga,KC,VC,De)),
  477        done) :- !.
  478%
  479% case 3 of RB: got a line
  480%
  481fix_left(black(red(red(Al,KA,VA,Be),KB,VB,Ga),KC,VC,De),
  482        black(red(Al,KA,VA,Be),KB,VB,red(Ga,KC,VC,De)),
  483        done) :- !.
  484%
  485% case 4 of RB: nothing to do
  486%
  487fix_left(T,T,done).
  488
  489%
  490% How to fix if we have inserted on the right
  491%
  492fix_right(done,T,T,done) :- !.
  493fix_right(not_done,Tmp,Final,Done) :-
  494    fix_right(Tmp,Final,Done).
  495
  496%
  497% case 1 of RB: just need to change colors.
  498%
  499fix_right(black(red(Ep,KD,VD,De),KC,VC,red(red(Ga,KB,VB,Be),KA,VA,Al)),
  500          red(black(Ep,KD,VD,De),KC,VC,black(red(Ga,KB,VB,Be),KA,VA,Al)),
  501          not_done) :- !.
  502fix_right(black(red(Ep,KD,VD,De),KC,VC,red(Ga,Ka,Va,red(Be,KB,VB,Al))),
  503          red(black(Ep,KD,VD,De),KC,VC,black(Ga,Ka,Va,red(Be,KB,VB,Al))),
  504          not_done) :- !.
  505%
  506% case 2 of RB: got a knee so need to do rotations
  507%
  508fix_right(black(De,KC,VC,red(red(Ga,KB,VB,Be),KA,VA,Al)),
  509          black(red(De,KC,VC,Ga),KB,VB,red(Be,KA,VA,Al)),
  510          done) :- !.
  511%
  512% case 3 of RB: got a line
  513%
  514fix_right(black(De,KC,VC,red(Ga,KB,VB,red(Be,KA,VA,Al))),
  515          black(red(De,KC,VC,Ga),KB,VB,red(Be,KA,VA,Al)),
  516          done) :- !.
  517%
  518% case 4 of RB: nothing to do.
  519%
  520fix_right(T,T,done).

 rb_delete(+Tree, +Key, -NewTree)

 rb_delete(+Tree, +Key, -Val, -NewTree)

Delete element with key Key from the tree Tree, returning the value Val associated with the key and a new tree NewTree.

  529rb_delete(t(Nil,T), K, t(Nil,NT)) :-
  530    delete(T, K, _, NT, _).
  531
  532rb_delete(t(Nil,T), K, V, t(Nil,NT)) :-
  533    delete(T, K, V0, NT, _),
  534    V = V0.
  535
  536%
  537% I am afraid our representation is not as nice for delete
  538%
  539delete(red(L,K0,V0,R), K, V, NT, Flag) :-
  540    K @< K0,
  541    !,
  542    delete(L, K, V, NL, Flag0),
  543    fixup_left(Flag0,red(NL,K0,V0,R),NT, Flag).
  544delete(red(L,K0,V0,R), K, V, NT, Flag) :-
  545    K @> K0,
  546    !,
  547    delete(R, K, V, NR, Flag0),
  548    fixup_right(Flag0,red(L,K0,V0,NR),NT, Flag).
  549delete(red(L,_,V,R), _, V, OUT, Flag) :-
  550    % K == K0,
  551    delete_red_node(L,R,OUT,Flag).
  552delete(black(L,K0,V0,R), K, V, NT, Flag) :-
  553    K @< K0,
  554    !,
  555    delete(L, K, V, NL, Flag0),
  556    fixup_left(Flag0,black(NL,K0,V0,R),NT, Flag).
  557delete(black(L,K0,V0,R), K, V, NT, Flag) :-
  558    K @> K0,
  559    !,
  560    delete(R, K, V, NR, Flag0),
  561    fixup_right(Flag0,black(L,K0,V0,NR),NT, Flag).
  562delete(black(L,_,V,R), _, V, OUT, Flag) :-
  563    % K == K0,
  564    delete_black_node(L,R,OUT,Flag).

 rb_del_min(+Tree, -Key, -Val, -NewTree)

Delete the least element from the tree Tree, returning the key Key, the value Val associated with the key and a new tree NewTree.

  571rb_del_min(t(Nil,T), K, Val, t(Nil,NT)) :-
  572    del_min(T, K, Val, Nil, NT, _).
  573
  574del_min(red(black('',_,_,_),K,V,R), K, V, Nil, OUT, Flag) :-
  575    !,
  576    delete_red_node(Nil,R,OUT,Flag).
  577del_min(red(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  578    del_min(L, K, V, Nil, NL, Flag0),
  579    fixup_left(Flag0,red(NL,K0,V0,R), NT, Flag).
  580del_min(black(black('',_,_,_),K,V,R), K, V, Nil, OUT, Flag) :-
  581    !,
  582    delete_black_node(Nil,R,OUT,Flag).
  583del_min(black(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  584    del_min(L, K, V, Nil, NL, Flag0),
  585    fixup_left(Flag0,black(NL,K0,V0,R),NT, Flag).

 rb_del_max(+Tree, -Key, -Val, -NewTree)

Delete the largest element from the tree Tree, returning the key Key, the value Val associated with the key and a new tree NewTree.

  593rb_del_max(t(Nil,T), K, Val, t(Nil,NT)) :-
  594    del_max(T, K, Val, Nil, NT, _).
  595
  596del_max(red(L,K,V,black('',_,_,_)), K, V, Nil, OUT, Flag) :-
  597    !,
  598    delete_red_node(L,Nil,OUT,Flag).
  599del_max(red(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  600    del_max(R, K, V, Nil, NR, Flag0),
  601    fixup_right(Flag0,red(L,K0,V0,NR),NT, Flag).
  602del_max(black(L,K,V,black('',_,_,_)), K, V, Nil, OUT, Flag) :-
  603    !,
  604    delete_black_node(L,Nil,OUT,Flag).
  605del_max(black(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  606    del_max(R, K, V, Nil, NR, Flag0),
  607    fixup_right(Flag0,black(L,K0,V0,NR), NT, Flag).
  608
  609delete_red_node(L1,L2,L1,done) :- L1 == L2, !.
  610delete_red_node(black('',_,_,''),R,R,done) :-  !.
  611delete_red_node(L,black('',_,_,''),L,done) :-  !.
  612delete_red_node(L,R,OUT,Done) :-
  613    delete_next(R,NK,NV,NR,Done0),
  614    fixup_right(Done0,red(L,NK,NV,NR),OUT,Done).
  615
  616delete_black_node(L1,L2,L1,not_done) :-         L1 == L2, !.
  617delete_black_node(black('',_,_,''),red(L,K,V,R),black(L,K,V,R),done) :- !.
  618delete_black_node(black('',_,_,''),R,R,not_done) :- !.
  619delete_black_node(red(L,K,V,R),black('',_,_,''),black(L,K,V,R),done) :- !.
  620delete_black_node(L,black('',_,_,''),L,not_done) :- !.
  621delete_black_node(L,R,OUT,Done) :-
  622    delete_next(R,NK,NV,NR,Done0),
  623    fixup_right(Done0,black(L,NK,NV,NR),OUT,Done).
  624
  625delete_next(red(black('',_,_,''),K,V,R),K,V,R,done) :-  !.
  626delete_next(black(black('',_,_,''),K,V,red(L1,K1,V1,R1)),
  627        K,V,black(L1,K1,V1,R1),done) :- !.
  628delete_next(black(black('',_,_,''),K,V,R),K,V,R,not_done) :- !.
  629delete_next(red(L,K,V,R),K0,V0,OUT,Done) :-
  630    delete_next(L,K0,V0,NL,Done0),
  631    fixup_left(Done0,red(NL,K,V,R),OUT,Done).
  632delete_next(black(L,K,V,R),K0,V0,OUT,Done) :-
  633    delete_next(L,K0,V0,NL,Done0),
  634    fixup_left(Done0,black(NL,K,V,R),OUT,Done).
  635
  636fixup_left(done,T,T,done).
  637fixup_left(not_done,T,NT,Done) :-
  638    fixup2(T,NT,Done).
  639
  640%
  641% case 1: x moves down, so we have to try to fix it again.
  642% case 1 -> 2,3,4 -> done
  643%
  644fixup2(black(black(Al,KA,VA,Be),KB,VB,
  645             red(black(Ga,KC,VC,De),KD,VD,
  646                 black(Ep,KE,VE,Fi))),
  647        black(T1,KD,VD,black(Ep,KE,VE,Fi)),done) :-
  648    !,
  649    fixup2(red(black(Al,KA,VA,Be),KB,VB,black(Ga,KC,VC,De)),
  650            T1,
  651            _).
  652%
  653% case 2: x moves up, change one to red
  654%
  655fixup2(red(black(Al,KA,VA,Be),KB,VB,
  656           black(black(Ga,KC,VC,De),KD,VD,
  657                 black(Ep,KE,VE,Fi))),
  658        black(black(Al,KA,VA,Be),KB,VB,
  659              red(black(Ga,KC,VC,De),KD,VD,
  660                  black(Ep,KE,VE,Fi))),done) :- !.
  661fixup2(black(black(Al,KA,VA,Be),KB,VB,
  662             black(black(Ga,KC,VC,De),KD,VD,
  663                   black(Ep,KE,VE,Fi))),
  664        black(black(Al,KA,VA,Be),KB,VB,
  665              red(black(Ga,KC,VC,De),KD,VD,
  666                  black(Ep,KE,VE,Fi))),not_done) :- !.
  667%
  668% case 3: x stays put, shift left and do a 4
  669%
  670fixup2(red(black(Al,KA,VA,Be),KB,VB,
  671           black(red(Ga,KC,VC,De),KD,VD,
  672                 black(Ep,KE,VE,Fi))),
  673        red(black(black(Al,KA,VA,Be),KB,VB,Ga),KC,VC,
  674            black(De,KD,VD,black(Ep,KE,VE,Fi))),
  675        done) :- !.
  676fixup2(black(black(Al,KA,VA,Be),KB,VB,
  677             black(red(Ga,KC,VC,De),KD,VD,
  678                   black(Ep,KE,VE,Fi))),
  679        black(black(black(Al,KA,VA,Be),KB,VB,Ga),KC,VC,
  680              black(De,KD,VD,black(Ep,KE,VE,Fi))),
  681        done) :- !.
  682%
  683% case 4: rotate left, get rid of red
  684%
  685fixup2(red(black(Al,KA,VA,Be),KB,VB,
  686           black(C,KD,VD,red(Ep,KE,VE,Fi))),
  687        red(black(black(Al,KA,VA,Be),KB,VB,C),KD,VD,
  688            black(Ep,KE,VE,Fi)),
  689        done).
  690fixup2(black(black(Al,KA,VA,Be),KB,VB,
  691             black(C,KD,VD,red(Ep,KE,VE,Fi))),
  692       black(black(black(Al,KA,VA,Be),KB,VB,C),KD,VD,
  693             black(Ep,KE,VE,Fi)),
  694       done).
  695
  696fixup_right(done,T,T,done).
  697fixup_right(not_done,T,NT,Done) :-
  698    fixup3(T,NT,Done).
  699
  700% case 1: x moves down, so we have to try to fix it again.
  701% case 1 -> 2,3,4 -> done
  702%
  703fixup3(black(red(black(Fi,KE,VE,Ep),KD,VD,
  704                 black(De,KC,VC,Ga)),KB,VB,
  705             black(Be,KA,VA,Al)),
  706        black(black(Fi,KE,VE,Ep),KD,VD,T1),done) :-
  707    !,
  708    fixup3(red(black(De,KC,VC,Ga),KB,VB,
  709               black(Be,KA,VA,Al)),T1,_).
  710
  711%
  712% case 2: x moves up, change one to red
  713%
  714fixup3(red(black(black(Fi,KE,VE,Ep),KD,VD,
  715                 black(De,KC,VC,Ga)),KB,VB,
  716           black(Be,KA,VA,Al)),
  717       black(red(black(Fi,KE,VE,Ep),KD,VD,
  718                 black(De,KC,VC,Ga)),KB,VB,
  719             black(Be,KA,VA,Al)),
  720       done) :- !.
  721fixup3(black(black(black(Fi,KE,VE,Ep),KD,VD,
  722                   black(De,KC,VC,Ga)),KB,VB,
  723             black(Be,KA,VA,Al)),
  724       black(red(black(Fi,KE,VE,Ep),KD,VD,
  725                 black(De,KC,VC,Ga)),KB,VB,
  726             black(Be,KA,VA,Al)),
  727       not_done):- !.
  728%
  729% case 3: x stays put, shift left and do a 4
  730%
  731fixup3(red(black(black(Fi,KE,VE,Ep),KD,VD,
  732                 red(De,KC,VC,Ga)),KB,VB,
  733           black(Be,KA,VA,Al)),
  734       red(black(black(Fi,KE,VE,Ep),KD,VD,De),KC,VC,
  735           black(Ga,KB,VB,black(Be,KA,VA,Al))),
  736       done) :- !.
  737fixup3(black(black(black(Fi,KE,VE,Ep),KD,VD,
  738                   red(De,KC,VC,Ga)),KB,VB,
  739             black(Be,KA,VA,Al)),
  740       black(black(black(Fi,KE,VE,Ep),KD,VD,De),KC,VC,
  741             black(Ga,KB,VB,black(Be,KA,VA,Al))),
  742       done) :- !.
  743%
  744% case 4: rotate right, get rid of red
  745%
  746fixup3(red(black(red(Fi,KE,VE,Ep),KD,VD,C),KB,VB,black(Be,KA,VA,Al)),
  747       red(black(Fi,KE,VE,Ep),KD,VD,black(C,KB,VB,black(Be,KA,VA,Al))),
  748       done).
  749fixup3(black(black(red(Fi,KE,VE,Ep),KD,VD,C),KB,VB,black(Be,KA,VA,Al)),
  750       black(black(Fi,KE,VE,Ep),KD,VD,black(C,KB,VB,black(Be,KA,VA,Al))),
  751       done).

 rb_visit(+Tree, -Pairs)

Pairs is an infix visit of tree Tree, where each element of Pairs is of the form Key-Value.

  758rb_visit(t(_,T),Lf) :-
  759    visit(T,[],Lf).
  760
  761visit(black('',_,_,_),L,L) :- !.
  762visit(red(L,K,V,R),L0,Lf) :-
  763    visit(L,[K-V|L1],Lf),
  764    visit(R,L0,L1).
  765visit(black(L,K,V,R),L0,Lf) :-
  766    visit(L,[K-V|L1],Lf),
  767    visit(R,L0,L1).
  768
  769:- meta_predicate map(?,2,?,?).  % this is required.

 rb_map(+T, :Goal) is semidet

True if call(Goal, Value) is true for all nodes in T.

  775rb_map(t(Nil,Tree),Goal,t(Nil,NewTree)) :-
  776    map(Tree,Goal,NewTree,Nil).
  777
  778
  779map(black('',_,_,''),_,Nil,Nil) :- !.
  780map(red(L,K,V,R),Goal,red(NL,K,NV,NR),Nil) :-
  781    call(Goal,V,NV),
  782    !,
  783    map(L,Goal,NL,Nil),
  784    map(R,Goal,NR,Nil).
  785map(black(L,K,V,R),Goal,black(NL,K,NV,NR),Nil) :-
  786    call(Goal,V,NV),
  787    !,
  788    map(L,Goal,NL,Nil),
  789    map(R,Goal,NR,Nil).
  790
  791:- meta_predicate map(?,1).  % this is required.

 rb_map(+Tree, :G, -NewTree) is semidet

For all nodes Key in the tree Tree, if the value associated with key Key is Val0 in tree Tree, and if call(G,Val0,ValF) holds, then the value associated with Key in NewTree is ValF. Fails if call(G,Val0,ValF) is not satisfiable for all Val0.

  800rb_map(t(_,Tree),Goal) :-
  801    map(Tree,Goal).
  802
  803
  804map(black('',_,_,''),_) :- !.
  805map(red(L,_,V,R),Goal) :-
  806    call(Goal,V),
  807    !,
  808    map(L,Goal),
  809    map(R,Goal).
  810map(black(L,_,V,R),Goal) :-
  811    call(Goal,V),
  812    !,
  813    map(L,Goal),
  814    map(R,Goal).

 rb_fold(:Goal, +Tree, +State0, -State) is det

Fold the given predicate over all the key-value pairs in Tree, starting with initial state State0 and returning the final state State. Pred is called as

call(Pred, Key-Value, State1, State2)

  824rb_fold(Pred, t(_,T), S1, S2) :-
  825    fold(T, Pred, S1, S2).
  826
  827fold(black(L,K,V,R), Pred) -->
  828    (   {L == ''}
  829    ->  []
  830    ;   fold_parts(Pred, L, K-V, R)
  831    ).
  832fold(red(L,K,V,R), Pred) -->
  833    fold_parts(Pred, L, K-V, R).
  834
  835fold_parts(Pred, L, KV, R) -->
  836    fold(L, Pred),
  837    call(Pred, KV),
  838    fold(R, Pred).

 rb_clone(+TreeIn, -TreeOut, -Pairs) is det

`Clone' the red-back tree TreeIn into a new tree TreeOut with the same keys as the original but with all values set to unbound values. Pairs is a list containing all new nodes as pairs K-V.

  846rb_clone(t(Nil,T),t(Nil,NT),Ns) :-
  847    clone(T,Nil,NT,Ns,[]).
  848
  849clone(black('',_,_,''),Nil,Nil,Ns,Ns) :- !.
  850clone(red(L,K,_,R),Nil,red(NL,K,NV,NR),NsF,Ns0) :-
  851    clone(L,Nil,NL,NsF,[K-NV|Ns1]),
  852    clone(R,Nil,NR,Ns1,Ns0).
  853clone(black(L,K,_,R),Nil,black(NL,K,NV,NR),NsF,Ns0) :-
  854    clone(L,Nil,NL,NsF,[K-NV|Ns1]),
  855    clone(R,Nil,NR,Ns1,Ns0).

 rb_partial_map(+Tree, +Keys, :G, -NewTree)

For all nodes Key in Keys, if the value associated with key Key is Val0 in tree Tree, and if call(G,Val0,ValF) holds, then the value associated with Key in NewTree is ValF. Fails if or if call(G,Val0,ValF) is not satisfiable for all Val0. Assumes keys are not repeated.

  865rb_partial_map(t(Nil,T0), Map, Goal, t(Nil,TF)) :-
  866    partial_map(T0, Map, [], Nil, Goal, TF).
  867
  868partial_map(T,[],[],_,_,T) :- !.
  869partial_map(black('',_,_,_),Map,Map,Nil,_,Nil) :- !.
  870partial_map(red(L,K,V,R),Map,MapF,Nil,Goal,red(NL,K,NV,NR)) :-
  871    partial_map(L,Map,MapI,Nil,Goal,NL),
  872    (   MapI == []
  873    ->  NR = R, NV = V, MapF = []
  874    ;   MapI = [K1|MapR],
  875        (   K == K1
  876        ->  (   call(Goal,V,NV)
  877            ->  true
  878            ;   NV = V
  879            ),
  880            MapN = MapR
  881        ;   NV = V,
  882            MapN = MapI
  883        ),
  884        partial_map(R,MapN,MapF,Nil,Goal,NR)
  885    ).
  886partial_map(black(L,K,V,R),Map,MapF,Nil,Goal,black(NL,K,NV,NR)) :-
  887    partial_map(L,Map,MapI,Nil,Goal,NL),
  888    (   MapI == []
  889    ->  NR = R, NV = V, MapF = []
  890    ;   MapI = [K1|MapR],
  891        (   K == K1
  892        ->  (   call(Goal,V,NV)
  893            ->  true
  894            ;   NV = V
  895            ),
  896            MapN = MapR
  897        ;   NV = V,
  898            MapN = MapI
  899        ),
  900        partial_map(R,MapN,MapF,Nil,Goal,NR)
  901    ).

 rb_keys(+Tree, -Keys)

Keys is unified with an ordered list of all keys in the Red-Black tree Tree.

  909rb_keys(t(_,T),Lf) :-
  910    keys(T,[],Lf).
  911
  912keys(black('',_,_,''),L,L) :- !.
  913keys(red(L,K,_,R),L0,Lf) :-
  914    keys(L,[K|L1],Lf),
  915    keys(R,L0,L1).
  916keys(black(L,K,_,R),L0,Lf) :-
  917    keys(L,[K|L1],Lf),
  918    keys(R,L0,L1).

 list_to_rbtree(+List, -Tree) is det

Tree is the red-black tree corresponding to the mapping in List, which should be a list of Key-Value pairs. List should not contain more than one entry for each distinct key.

  927list_to_rbtree(List, T) :-
  928    sort(List,Sorted),
  929    ord_list_to_rbtree(Sorted, T).

 ord_list_to_rbtree(+List, -Tree) is det

Tree is the red-black tree corresponding to the mapping in list List, which should be a list of Key-Value pairs. List should not contain more than one entry for each distinct key. List is assumed to be sorted according to the standard order of terms.

  938ord_list_to_rbtree([], t(Nil,Nil)) :-
  939    !,
  940    Nil = black('', _, _, '').
  941ord_list_to_rbtree([K-V], t(Nil,black(Nil,K,V,Nil))) :-
  942    !,
  943    Nil = black('', _, _, '').
  944ord_list_to_rbtree(List, t(Nil,Tree)) :-
  945    Nil = black('', _, _, ''),
  946    Ar =.. [seq|List],
  947    functor(Ar,_,L),
  948    Height is truncate(log(L)/log(2)),
  949    construct_rbtree(1, L, Ar, Height, Nil, Tree).
  950
  951construct_rbtree(L, M, _, _, Nil, Nil) :- M < L, !.
  952construct_rbtree(L, L, Ar, Depth, Nil, Node) :-
  953    !,
  954    arg(L, Ar, K-Val),
  955    build_node(Depth, Nil, K, Val, Nil, Node).
  956construct_rbtree(I0, Max, Ar, Depth, Nil, Node) :-
  957    I is (I0+Max)//2,
  958    arg(I, Ar, K-Val),
  959    build_node(Depth, Left, K, Val, Right, Node),
  960    I1 is I-1,
  961    NewDepth is Depth-1,
  962    construct_rbtree(I0, I1, Ar, NewDepth, Nil, Left),
  963    I2 is I+1,
  964    construct_rbtree(I2, Max, Ar, NewDepth, Nil, Right).
  965
  966build_node( 0, Left, K, Val, Right, red(Left, K, Val, Right)) :- !.
  967build_node( _, Left, K, Val, Right, black(Left, K, Val, Right)).

 rb_size(+Tree, -Size) is det

Size is the number of elements in Tree.

  974rb_size(t(_,T),Size) :-
  975    size(T,0,Size).
  976
  977size(black('',_,_,_),Sz,Sz) :- !.
  978size(red(L,_,_,R),Sz0,Szf) :-
  979    Sz1 is Sz0+1,
  980    size(L,Sz1,Sz2),
  981    size(R,Sz2,Szf).
  982size(black(L,_,_,R),Sz0,Szf) :-
  983    Sz1 is Sz0+1,
  984    size(L,Sz1,Sz2),
  985    size(R,Sz2,Szf).

 is_rbtree(@Term) is semidet

True if Term is a valide Red-Black tree.

To be done

- Catch variables.

  993is_rbtree(X) :-
  994    var(X), !, fail.
  995is_rbtree(t(Nil,Nil)) :- !.
  996is_rbtree(t(_,T)) :-
  997    catch(rbtree1(T), msg(_,_), fail).
  998
  999%
 1000% This code checks if a tree is ordered and a rbtree
 1001%
 1002
 1003rbtree1(black(L,K,_,R)) :-
 1004    find_path_blacks(L, 0, Bls),
 1005    check_rbtree(L,-inf,K,Bls),
 1006    check_rbtree(R,K,+inf,Bls).
 1007rbtree1(red(_,_,_,_)) :-
 1008    throw(msg("root should be black",[])).
 1009
 1010
 1011find_path_blacks(black('',_,_,''), Bls, Bls) :- !.
 1012find_path_blacks(black(L,_,_,_), Bls0, Bls) :-
 1013    Bls1 is Bls0+1,
 1014    find_path_blacks(L, Bls1, Bls).
 1015find_path_blacks(red(L,_,_,_), Bls0, Bls) :-
 1016    find_path_blacks(L, Bls0, Bls).
 1017
 1018check_rbtree(black('',_,_,''),Min,Max,Bls0) :-
 1019    !,
 1020    check_height(Bls0,Min,Max).
 1021check_rbtree(red(L,K,_,R),Min,Max,Bls) :-
 1022    check_val(K,Min,Max),
 1023    check_red_child(L),
 1024    check_red_child(R),
 1025    check_rbtree(L,Min,K,Bls),
 1026    check_rbtree(R,K,Max,Bls).
 1027check_rbtree(black(L,K,_,R),Min,Max,Bls0) :-
 1028    check_val(K,Min,Max),
 1029    Bls is Bls0-1,
 1030    check_rbtree(L,Min,K,Bls),
 1031    check_rbtree(R,K,Max,Bls).
 1032
 1033check_height(0,_,_) :- !.
 1034check_height(Bls0,Min,Max) :-
 1035    throw(msg("Unbalance ~d between ~w and ~w~n",[Bls0,Min,Max])).
 1036
 1037check_val(K, Min, Max) :- ( K @> Min ; Min == -inf), (K @< Max ; Max == +inf), !.
 1038check_val(K, Min, Max) :-
 1039    throw(msg("not ordered: ~w not between ~w and ~w~n",[K,Min,Max])).
 1040
 1041check_red_child(black(_,_,_,_)).
 1042check_red_child(red(_,K,_,_)) :-
 1043    throw(msg("must be red: ~w~n",[K]))