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          ]).   65
   66/** <module> Red black trees
   67
   68Red-Black trees are balanced search binary trees. They are named because
   69nodes can be classified as either red or   black. The code we include is
   70based on "Introduction  to  Algorithms",   second  edition,  by  Cormen,
   71Leiserson, Rivest and Stein. The library   includes  routines to insert,
   72lookup and delete elements in the tree.
   73
   74A Red black tree is represented as a term t(Nil, Tree), where Nil is the
   75Nil-node, a node shared for each nil-node in  the tree. Any node has the
   76form colour(Left, Key, Value, Right), where _colour_  is one of =red= or
   77=black=.
   78
   79@author Vitor Santos Costa, Jan Wielemaker, Samer Abdallah
   80@see "Introduction to Algorithms", Second Edition Cormen, Leiserson,
   81     Rivest, and Stein, MIT Press
   82*/
   83
   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*/
  113
  114%!  rb_new(-Tree) is det.
  115%
  116%   Create a new Red-Black tree Tree.
  117%
  118%   @deprecated     Use rb_empty/1.
  119
  120rb_new(t(Nil,Nil)) :-
  121    Nil = black('',_,_,'').
  122
  123%!  rb_empty(?Tree) is semidet.
  124%
  125%   Succeeds if Tree is an empty Red-Black tree.
  126
  127rb_empty(t(Nil,Nil)) :-
  128    Nil = black('',_,_,'').
  129
  130%!  rb_lookup(+Key, -Value, +Tree) is semidet.
  131%
  132%   True when Value is associated with Key   in the Red-Black tree Tree.
  133%   The given Key may include variables, in   which  case the RB tree is
  134%   searched for a key with equivalent,   as  in (==)/2, variables. Time
  135%   complexity is O(log N) in the number of elements in the tree.
  136
  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).
  154
  155%!  rb_min(+Tree, -Key, -Value) is semidet.
  156%
  157%   Key is the minimum key in Tree, and is associated with Val.
  158
  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).
  168
  169%!  rb_max(+Tree, -Key, -Value) is semidet.
  170%
  171%   Key is the maximal key in Tree, and is associated with Val.
  172
  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).
  182
  183%!  rb_next(+Tree, +Key, -Next, -Value) is semidet.
  184%
  185%   Next is the next element after Key   in Tree, and is associated with
  186%   Val.
  187
  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    ).
  210
  211%!  rb_previous(+Tree, +Key, -Previous, -Value) is semidet.
  212%
  213%   Previous  is  the  previous  element  after  Key  in  Tree,  and  is
  214%   associated with Val.
  215
  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    ).
  238
  239%!  rb_update(+Tree, +Key, +NewVal, -NewTree) is semidet.
  240%!  rb_update(+Tree, +Key, ?OldVal, +NewVal, -NewTree) is semidet.
  241%
  242%   Tree NewTree is tree Tree, but with   value  for Key associated with
  243%   NewVal. Fails if it cannot find Key in Tree.
  244
  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    ).
  274
  275%!  rb_apply(+Tree, +Key, :G, -NewTree) is semidet.
  276%
  277%   If the value associated  with  key  Key   is  Val0  in  Tree, and if
  278%   call(G,Val0,ValF) holds, then NewTree differs from Tree only in that
  279%   Key is associated with value  ValF  in   tree  NewTree.  Fails if it
  280%   cannot find Key in Tree, or if call(G,Val0,ValF) is not satisfiable.
  281
  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    ).
  317
  318%!  rb_in(?Key, ?Value, +Tree) is nondet.
  319%
  320%   True when Key-Value is a key-value pair in red-black tree Tree. Same
  321%   as below, but does not materialize the pairs.
  322%
  323%        rb_visit(Tree, Pairs), member(Key-Value, Pairs)
  324
  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.
  347
  348%!  rb_insert(+Tree, +Key, ?Value, -NewTree) is det.
  349%
  350%   Add an element with key Key and Value   to  the tree Tree creating a
  351%   new red-black tree NewTree. If Key is  a key in Tree, the associated
  352%   value is replaced by Value. See also rb_insert_new/4.
  353
  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.
  411
  412%!  rb_insert_new(+Tree, +Key, ?Value, -NewTree) is semidet.
  413%
  414%   Add a new element with key Key and Value to the tree Tree creating a
  415%   new red-black tree NewTree. Fails if Key is a key in Tree.
  416
  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).
  521
  522
  523%!  rb_delete(+Tree, +Key, -NewTree).
  524%!  rb_delete(+Tree, +Key, -Val, -NewTree).
  525%
  526%   Delete element with key Key from the  tree Tree, returning the value
  527%   Val associated with the key and a new tree NewTree.
  528
  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).
  565
  566%!  rb_del_min(+Tree, -Key, -Val, -NewTree)
  567%
  568%   Delete the least element from the tree  Tree, returning the key Key,
  569%   the value Val associated with the key and a new tree NewTree.
  570
  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).
  586
  587
  588%!  rb_del_max(+Tree, -Key, -Val, -NewTree)
  589%
  590%   Delete the largest element from  the   tree  Tree, returning the key
  591%   Key, the value Val associated with the key and a new tree NewTree.
  592
  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).
  752
  753%!  rb_visit(+Tree, -Pairs)
  754%
  755%   Pairs is an infix visit of tree Tree, where each element of Pairs is
  756%   of the form Key-Value.
  757
  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.
  770
  771%!  rb_map(+T, :Goal) is semidet.
  772%
  773%   True if call(Goal, Value) is true for all nodes in T.
  774
  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.
  792
  793%!  rb_map(+Tree, :G, -NewTree) is semidet.
  794%
  795%   For all nodes Key in the tree Tree, if the value associated with key
  796%   Key is Val0 in tree Tree, and   if call(G,Val0,ValF) holds, then the
  797%   value  associated  with  Key  in   NewTree    is   ValF.   Fails  if
  798%   call(G,Val0,ValF) is not satisfiable for all Val0.
  799
  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).
  815
  816%!  rb_fold(:Goal, +Tree, +State0, -State) is det.
  817%
  818%   Fold the given predicate  over  all   the  key-value  pairs in Tree,
  819%   starting with initial state State0  and   returning  the final state
  820%   State. Pred is called as
  821%
  822%       call(Pred, Key-Value, State1, State2)
  823
  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).
  839
  840%!  rb_clone(+TreeIn, -TreeOut, -Pairs) is det.
  841%
  842%   `Clone' the red-back tree TreeIn into a   new  tree TreeOut with the
  843%   same keys as the original but with all values set to unbound values.
  844%   Pairs is a list containing all new nodes as pairs K-V.
  845
  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).
  856
  857%!  rb_partial_map(+Tree, +Keys, :G, -NewTree)
  858%
  859%   For all nodes Key in Keys, if the   value associated with key Key is
  860%   Val0 in tree Tree, and if   call(G,Val0,ValF)  holds, then the value
  861%   associated  with  Key  in  NewTree   is    ValF.   Fails  if  or  if
  862%   call(G,Val0,ValF) is not satisfiable for all  Val0. Assumes keys are
  863%   not repeated.
  864
  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    ).
  902
  903
  904%!  rb_keys(+Tree, -Keys)
  905%
  906%   Keys is unified with an ordered list   of  all keys in the Red-Black
  907%   tree Tree.
  908
  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).
  919
  920
  921%!  list_to_rbtree(+List, -Tree) is det.
  922%
  923%   Tree is the red-black tree  corresponding   to  the mapping in List,
  924%   which should be a list of Key-Value   pairs. List should not contain
  925%   more than one entry for each distinct key.
  926
  927list_to_rbtree(List, T) :-
  928    sort(List,Sorted),
  929    ord_list_to_rbtree(Sorted, T).
  930
  931%!  ord_list_to_rbtree(+List, -Tree) is det.
  932%
  933%   Tree is the red-black tree  corresponding   to  the  mapping in list
  934%   List, which should be a list  of   Key-Value  pairs. List should not
  935%   contain more than one entry for each   distinct key. List is assumed
  936%   to be sorted according to the standard order of terms.
  937
  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)).
  968
  969
  970%!  rb_size(+Tree, -Size) is det.
  971%
  972%   Size is the number of elements in Tree.
  973
  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).
  986
  987%!  is_rbtree(@Term) is semidet.
  988%
  989%   True if Term is a valide Red-Black tree.
  990%
  991%   @tbd    Catch variables.
  992
  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]))