View source with raw comments or as raw

    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          ]).

Red black trees

Red-Black trees are balanced search binary trees. They are named because nodes can be classified as either red or black. The code we include is based on "Introduction to Algorithms", second edition, by Cormen, Leiserson, Rivest and Stein. The library includes routines to insert, lookup and delete elements in the tree.

A Red black tree is represented as a term t(Nil, Tree), where Nil is the Nil-node, a node shared for each nil-node in the tree. Any node has the form colour(Left, Key, Value, Right), where colour is one of red or black.

author: - Vitor Santos Costa, Jan Wielemaker, Samer Abdallah
See also: -
"Introduction to Algorithms", Second Edition Cormen, Leiserson, Rivest, and Stein, MIT Press */

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

rb_new(-Tree) is det

Create a new Red-Black tree Tree.

deprecated: - Use rb_empty/1.

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

rb_empty(?Tree) is semidet: Succeeds if Tree is an empty Red-Black tree.

  126rb_empty(t(Nil,Nil)) :-
  127    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.

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

rb_min(+Tree, -Key, -Value) is semidet: Key is the minimum key in Tree, and is associated with Val.

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

rb_max(+Tree, -Key, -Value) is semidet: Key is the maximal key in Tree, and is associated with Val.

  172rb_max(t(_,Tree), Key, Val) :-
  173    max(Tree, Key, Val).
  174
  175max(red(_,Key,Val,black('',_,_,_)), Key, Val) :- !.
  176max(black(_,Key,Val,black('',_,_,_)), Key, Val) :- !.
  177max(red(_,_,_,Left), Key, Val) :-
  178    max(Left,Key,Val).
  179max(black(_,_,_,Left), Key, Val) :-
  180    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.

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

rb_previous(+Tree, +Key, -Previous, -Value) is semidet: Previous is the previous element after Key in Tree, and is associated with Val.

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

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.

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

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.

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

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)

  324rb_in(Key, Val, t(_,T)) :-
  325    enum(Key, Val, T).
  326
  327enum(Key, Val, black(L,K,V,R)) :-
  328    L \= '',
  329    enum_cases(Key, Val, L, K, V, R).
  330enum(Key, Val, red(L,K,V,R)) :-
  331    enum_cases(Key, Val, L, K, V, R).
  332
  333enum_cases(Key, Val, L, _, _, _) :-
  334    enum(Key, Val, L).
  335enum_cases(Key, Val, _, Key, Val, _).
  336enum_cases(Key, Val, _, _, _, R) :-
  337    enum(Key, Val, R).
  338
  339
  340
  341                 /*******************************
  342                 *       TREE INSERTION         *
  343                 *******************************/
  344
  345% 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.

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

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

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

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

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

rb_visit(+Tree, -Pairs): Pairs is an infix visit of tree Tree, where each element of Pairs is of the form Key-Value.

  757rb_visit(t(_,T),Lf) :-
  758    visit(T,[],Lf).
  759
  760visit(black('',_,_,_),L,L) :- !.
  761visit(red(L,K,V,R),L0,Lf) :-
  762    visit(L,[K-V|L1],Lf),
  763    visit(R,L0,L1).
  764visit(black(L,K,V,R),L0,Lf) :-
  765    visit(L,[K-V|L1],Lf),
  766    visit(R,L0,L1).
  767
  768:- meta_predicate rb_map(?,:,?). % this is not strictly required
  769:- meta_predicate map(?,:,?,?).  % 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 rb_map(?,:). % this is not strictly required
  792:- meta_predicate map(?,:).  % 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.

  801rb_map(t(_,Tree),Goal) :-
  802    map(Tree,Goal).
  803
  804
  805map(black('',_,_,''),_) :- !.
  806map(red(L,_,V,R),Goal) :-
  807    call(Goal,V),
  808    !,
  809    map(L,Goal),
  810    map(R,Goal).
  811map(black(L,_,V,R),Goal) :-
  812    call(Goal,V),
  813    !,
  814    map(L,Goal),
  815    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)

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

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

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

rb_keys(+Tree, -Keys): Keys is unified with an ordered list of all keys in the Red-Black tree Tree.

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

  928list_to_rbtree(List, T) :-
  929    sort(List,Sorted),
  930    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.

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

rb_size(+Tree, -Size) is det: Size is the number of elements in Tree.

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

is_rbtree(@Term) is semidet

True if Term is a valide Red-Black tree.

To be done: - Catch variables.

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