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(+,:,-),
   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*/
  112
  113%!  rb_new(-Tree) is det.
  114%
  115%   Create a new Red-Black tree Tree.
  116%
  117%   @deprecated     Use rb_empty/1.
  118
  119rb_new(t(Nil,Nil)) :-
  120    Nil = black('',_,_,'').
  121
  122%!  rb_empty(?Tree) is semidet.
  123%
  124%   Succeeds if Tree is an empty Red-Black tree.
  125
  126rb_empty(t(Nil,Nil)) :-
  127    Nil = black('',_,_,'').
  128
  129%!  rb_lookup(+Key, -Value, +Tree) is semidet.
  130%
  131%   True when Value is associated with Key   in the Red-Black tree Tree.
  132%   The given Key may include variables, in   which  case the RB tree is
  133%   searched for a key with equivalent,   as  in (==)/2, variables. Time
  134%   complexity is O(log N) in the number of elements in the tree.
  135
  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).
  153
  154%!  rb_min(+Tree, -Key, -Value) is semidet.
  155%
  156%   Key is the minimum key in Tree, and is associated with Val.
  157
  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).
  167
  168%!  rb_max(+Tree, -Key, -Value) is semidet.
  169%
  170%   Key is the maximal key in Tree, and is associated with Val.
  171
  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).
  181
  182%!  rb_next(+Tree, +Key, -Next, -Value) is semidet.
  183%
  184%   Next is the next element after Key   in Tree, and is associated with
  185%   Val.
  186
  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    ).
  209
  210%!  rb_previous(+Tree, +Key, -Previous, -Value) is semidet.
  211%
  212%   Previous  is  the  previous  element  after  Key  in  Tree,  and  is
  213%   associated with Val.
  214
  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    ).
  237
  238%!  rb_update(+Tree, +Key, +NewVal, -NewTree) is semidet.
  239%!  rb_update(+Tree, +Key, ?OldVal, +NewVal, -NewTree) is semidet.
  240%
  241%   Tree NewTree is tree Tree, but with   value  for Key associated with
  242%   NewVal. Fails if it cannot find Key in Tree.
  243
  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    ).
  273
  274%!  rb_apply(+Tree, +Key, :G, -NewTree) is semidet.
  275%
  276%   If the value associated  with  key  Key   is  Val0  in  Tree, and if
  277%   call(G,Val0,ValF) holds, then NewTree differs from Tree only in that
  278%   Key is associated with value  ValF  in   tree  NewTree.  Fails if it
  279%   cannot find Key in Tree, or if call(G,Val0,ValF) is not satisfiable.
  280
  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    ).
  316
  317%!  rb_in(?Key, ?Value, +Tree) is nondet.
  318%
  319%   True when Key-Value is a key-value pair in red-black tree Tree. Same
  320%   as below, but does not materialize the pairs.
  321%
  322%        rb_visit(Tree, Pairs), member(Key-Value, Pairs)
  323
  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.
  346
  347%!  rb_insert(+Tree, +Key, ?Value, -NewTree) is det.
  348%
  349%   Add an element with key Key and Value   to  the tree Tree creating a
  350%   new red-black tree NewTree. If Key is  a key in Tree, the associated
  351%   value is replaced by Value. See also rb_insert_new/4.
  352
  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.
  410
  411%!  rb_insert_new(+Tree, +Key, ?Value, -NewTree) is semidet.
  412%
  413%   Add a new element with key Key and Value to the tree Tree creating a
  414%   new red-black tree NewTree. Fails if Key is a key in Tree.
  415
  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).
  520
  521
  522%!  rb_delete(+Tree, +Key, -NewTree).
  523%!  rb_delete(+Tree, +Key, -Val, -NewTree).
  524%
  525%   Delete element with key Key from the  tree Tree, returning the value
  526%   Val associated with the key and a new tree NewTree.
  527
  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).
  564
  565%!  rb_del_min(+Tree, -Key, -Val, -NewTree)
  566%
  567%   Delete the least element from the tree  Tree, returning the key Key,
  568%   the value Val associated with the key and a new tree NewTree.
  569
  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).
  585
  586
  587%!  rb_del_max(+Tree, -Key, -Val, -NewTree)
  588%
  589%   Delete the largest element from  the   tree  Tree, returning the key
  590%   Key, the value Val associated with the key and a new tree NewTree.
  591
  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).
  751
  752%!  rb_visit(+Tree, -Pairs)
  753%
  754%   Pairs is an infix visit of tree Tree, where each element of Pairs is
  755%   of the form Key-Value.
  756
  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.
  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 rb_map(?,:). % this is not strictly required
  792:- meta_predicate map(?,:).  % this is required.
  793
  794%!  rb_map(+Tree, :G, -NewTree) is semidet.
  795%
  796%   For all nodes Key in the tree Tree, if the value associated with key
  797%   Key is Val0 in tree Tree, and   if call(G,Val0,ValF) holds, then the
  798%   value  associated  with  Key  in   NewTree    is   ValF.   Fails  if
  799%   call(G,Val0,ValF) is not satisfiable for all Val0.
  800
  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).
  816
  817%!  rb_fold(:Goal, +Tree, +State0, -State) is det.
  818%
  819%   Fold the given predicate  over  all   the  key-value  pairs in Tree,
  820%   starting with initial state State0  and   returning  the final state
  821%   State. Pred is called as
  822%
  823%       call(Pred, Key-Value, State1, State2)
  824
  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).
  840
  841%!  rb_clone(+TreeIn, -TreeOut, -Pairs) is det.
  842%
  843%   `Clone' the red-back tree TreeIn into a   new  tree TreeOut with the
  844%   same keys as the original but with all values set to unbound values.
  845%   Pairs is a list containing all new nodes as pairs K-V.
  846
  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).
  857
  858%!  rb_partial_map(+Tree, +Keys, :G, -NewTree)
  859%
  860%   For all nodes Key in Keys, if the   value associated with key Key is
  861%   Val0 in tree Tree, and if   call(G,Val0,ValF)  holds, then the value
  862%   associated  with  Key  in  NewTree   is    ValF.   Fails  if  or  if
  863%   call(G,Val0,ValF) is not satisfiable for all  Val0. Assumes keys are
  864%   not repeated.
  865
  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    ).
  903
  904
  905%!  rb_keys(+Tree, -Keys)
  906%
  907%   Keys is unified with an ordered list   of  all keys in the Red-Black
  908%   tree Tree.
  909
  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).
  920
  921
  922%!  list_to_rbtree(+List, -Tree) is det.
  923%
  924%   Tree is the red-black tree  corresponding   to  the mapping in List,
  925%   which should be a list of Key-Value   pairs. List should not contain
  926%   more than one entry for each distinct key.
  927
  928list_to_rbtree(List, T) :-
  929    sort(List,Sorted),
  930    ord_list_to_rbtree(Sorted, T).
  931
  932%!  ord_list_to_rbtree(+List, -Tree) is det.
  933%
  934%   Tree is the red-black tree  corresponding   to  the  mapping in list
  935%   List, which should be a list  of   Key-Value  pairs. List should not
  936%   contain more than one entry for each   distinct key. List is assumed
  937%   to be sorted according to the standard order of terms.
  938
  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)).
  969
  970
  971%!  rb_size(+Tree, -Size) is det.
  972%
  973%   Size is the number of elements in Tree.
  974
  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).
  987
  988%!  is_rbtree(@Term) is semidet.
  989%
  990%   True if Term is a valide Red-Black tree.
  991%
  992%   @tbd    Catch variables.
  993
  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]))