1/*  Part of SWI-Prolog
    2
    3    Author:        Vitor Santos Costa
    4    E-mail:        vscosta@gmail.com
    5    WWW:           http://www.swi-prolog.org
    6    Copyright (c)  2007-2021, Vitor Santos Costa
    7    All rights reserved.
    8
    9    Redistribution and use in source and binary forms, with or without
   10    modification, are permitted provided that the following conditions
   11    are met:
   12
   13    1. Redistributions of source code must retain the above copyright
   14       notice, this list of conditions and the following disclaimer.
   15
   16    2. Redistributions in binary form must reproduce the above copyright
   17       notice, this list of conditions and the following disclaimer in
   18       the documentation and/or other materials provided with the
   19       distribution.
   20
   21    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   22    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   23    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   24    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   25    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   26    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   27    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   28    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   29    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   30    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   31    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   32    POSSIBILITY OF SUCH DAMAGE.
   33*/
   34
   35:- module(rbtrees,
   36          [ rb_new/1,                   % -Tree
   37            rb_empty/1,                 % ?Tree
   38            rb_lookup/3,                % +Key, -Value, +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:- autoload(library(error), [domain_error/2]).   66
   67/** <module> Red black trees
   68
   69Red-Black trees are balanced search binary trees. They are named because
   70nodes can be classified as either red or   black. The code we include is
   71based on "Introduction  to  Algorithms",   second  edition,  by  Cormen,
   72Leiserson, Rivest and Stein. The library   includes  routines to insert,
   73lookup and delete elements in the tree.
   74
   75A Red black tree is represented as a term t(Nil, Tree), where Nil is the
   76Nil-node, a node shared for each nil-node in  the tree. Any node has the
   77form colour(Left, Key, Value, Right), where _colour_  is one of =red= or
   78=black=.
   79
   80@author Vitor Santos Costa, Jan Wielemaker, Samer Abdallah,
   81        Peter Ludemann.
   82@see "Introduction to Algorithms", Second Edition Cormen, Leiserson,
   83     Rivest, and Stein, MIT Press
   84*/
   85
   86% rbtrees.pl is derived from YAP's rbtrees.yap, with some minor editing.
   87% One difference is that the SWI-Prolog version  assumes that a key only
   88% appears once in the tree - the   YAP  code is somewhat inconsistent in
   89% that  (and  even  allows  rb_lookup/3  to    backtrack,  plus  it  has
   90% rb_lookupall/3, which isn't in the SWI-Prolog code).
   91
   92% The code has also been modified to   use SWI-Prolog's '=>' operator to
   93% throw an existence_error(matching_rule, _)  exception   if  Tree isn't
   94% instantiated (if ':-' is used, an  uninstanted   Tree  gets  set to an
   95% empty tree, which probably isn't the desired result).
   96
   97:- meta_predicate
   98    rb_map(+,2,-),
   99    rb_map(?,1),
  100    rb_partial_map(+,+,2,-),
  101    rb_apply(+,+,2,-),
  102    rb_fold(3,+,+,-).  103
  104/*
  105:- use_module(library(type_check)).
  106
  107:- type rbtree(K,V) ---> t(tree(K,V),tree(K,V)).
  108:- type tree(K,V)   ---> black(tree(K,V),K,V,tree(K,V))
  109                       ; red(tree(K,V),K,V,tree(K,V))
  110                       ; ''.
  111:- type cmp ---> (=) ; (<) ; (>).
  112
  113
  114:- pred rb_new(rbtree(_K,_V)).
  115:- pred rb_empty(rbtree(_K,_V)).
  116:- pred rb_lookup(K,V,rbtree(K,V)).
  117:- pred lookup(K,V, tree(K,V)).
  118:- pred lookup(cmp, K, V, tree(K,V)).
  119:- pred rb_min(rbtree(K,V),K,V).
  120:- pred min(tree(K,V),K,V).
  121:- pred rb_max(rbtree(K,V),K,V).
  122:- pred max(tree(K,V),K,V).
  123:- pred rb_next(rbtree(K,V),K,pair(K,V),V).
  124:- pred next(tree(K,V),K,pair(K,V),V,tree(K,V)).
  125*/
  126
  127%!  rb_new(-Tree) is det.
  128%
  129%   Create a new Red-Black tree Tree.
  130%
  131%   @deprecated     Use rb_empty/1.
  132
  133:- det(rb_new/1).  134rb_new(t(Nil,Nil)) :-
  135    Nil = black('',_,_,'').
  136
  137%!  rb_empty(?Tree) is semidet.
  138%
  139%   Succeeds if Tree is an empty Red-Black tree.
  140
  141rb_empty(t(Nil,Nil)) :-
  142    Nil = black('',_,_,'').
  143
  144%!  rb_lookup(+Key, -Value, +Tree) is semidet.
  145%
  146%   True when Value is associated with Key   in the Red-Black tree Tree.
  147%   The given Key may include variables, in   which  case the RB tree is
  148%   searched for a key with equivalent,   as  in (==)/2, variables. Time
  149%   complexity is O(log N) in the number of elements in the tree.
  150
  151rb_lookup(Key, Val, t(_,Tree)) =>
  152    lookup(Key, Val, Tree).
  153
  154lookup(_, _, black('',_,_,'')) :- !, fail.
  155lookup(Key, Val, Tree) :-
  156    arg(2,Tree,KA),
  157    compare(Cmp,KA,Key),
  158    lookup(Cmp,Key,Val,Tree).
  159
  160lookup(>, K, V, Tree) :-
  161    arg(1,Tree,NTree),
  162    lookup(K, V, NTree).
  163lookup(<, K, V, Tree) :-
  164    arg(4,Tree,NTree),
  165    lookup(K, V, NTree).
  166lookup(=, _, V, Tree) :-
  167    arg(3,Tree,V).
  168
  169%!  rb_min(+Tree, -Key, -Value) is semidet.
  170%
  171%   Key is the minimum key in Tree, and is associated with Val.
  172
  173rb_min(t(_,Tree), Key, Val) =>
  174    min(Tree, Key, Val).
  175
  176min(red(black('',_,_,_),Key,Val,_), Key, Val) :- !.
  177min(black(black('',_,_,_),Key,Val,_), Key, Val) :- !.
  178min(red(Right,_,_,_), Key, Val) :-
  179    min(Right,Key,Val).
  180min(black(Right,_,_,_), Key, Val) :-
  181    min(Right,Key,Val).
  182
  183%!  rb_max(+Tree, -Key, -Value) is semidet.
  184%
  185%   Key is the maximal key in Tree, and is associated with Val.
  186
  187rb_max(t(_,Tree), Key, Val) =>
  188    max(Tree, Key, Val).
  189
  190max(red(_,Key,Val,black('',_,_,_)), Key, Val) :- !.
  191max(black(_,Key,Val,black('',_,_,_)), Key, Val) :- !.
  192max(red(_,_,_,Left), Key, Val) :-
  193    max(Left,Key,Val).
  194max(black(_,_,_,Left), Key, Val) :-
  195    max(Left,Key,Val).
  196
  197%!  rb_next(+Tree, +Key, -Next, -Value) is semidet.
  198%
  199%   Next is the next element after Key   in Tree, and is associated with
  200%   Val. Fails if Key isn't in Tree or if Key is the maximum key.
  201
  202rb_next(t(_,Tree), Key, Next, Val) =>
  203    next(Tree, Key, Next, Val, []).
  204
  205next(black('',_,_,''), _, _, _, _) :- !, fail.
  206next(Tree, Key, Next, Val, Candidate) :-
  207    arg(2,Tree,KA),
  208    arg(3,Tree,VA),
  209    compare(Cmp,KA,Key),
  210    next(Cmp, Key, KA, VA, Next, Val, Tree, Candidate).
  211
  212next(>, K, KA, VA, NK, V, Tree, _) :-
  213    arg(1,Tree,NTree),
  214    next(NTree,K,NK,V,KA-VA).
  215next(<, K, _, _, NK, V, Tree, Candidate) :-
  216    arg(4,Tree,NTree),
  217    next(NTree,K,NK,V,Candidate).
  218next(=, _, _, _, NK, Val, Tree, Candidate) :-
  219    arg(4,Tree,NTree),
  220    (   min(NTree, NK, Val)
  221    ->  true
  222    ;   Candidate = (NK-Val)
  223    ).
  224
  225%!  rb_previous(+Tree, +Key, -Previous, -Value) is semidet.
  226%
  227%   Previous  is  the  previous  element  after  Key  in  Tree,  and  is
  228%   associated with Val. Fails if Key isn't  in   Tree  or if Key is the
  229%   minimum key.
  230
  231rb_previous(t(_,Tree), Key, Previous, Val) =>
  232    previous(Tree, Key, Previous, Val, []).
  233
  234previous(black('',_,_,''), _, _, _, _) :- !, fail.
  235previous(Tree, Key, Previous, Val, Candidate) :-
  236    arg(2,Tree,KA),
  237    arg(3,Tree,VA),
  238    compare(Cmp,KA,Key),
  239    previous(Cmp, Key, KA, VA, Previous, Val, Tree, Candidate).
  240
  241previous(>, K, _, _, NK, V, Tree, Candidate) :-
  242    arg(1,Tree,NTree),
  243    previous(NTree,K,NK,V,Candidate).
  244previous(<, K, KA, VA, NK, V, Tree, _) :-
  245    arg(4,Tree,NTree),
  246    previous(NTree,K,NK,V,KA-VA).
  247previous(=, _, _, _, K, Val, Tree, Candidate) :-
  248    arg(1,Tree,NTree),
  249    (   max(NTree, K, Val)
  250    ->  true
  251    ;   Candidate = (K-Val)
  252    ).
  253
  254%!  rb_update(+Tree, +Key, +NewVal, -NewTree) is semidet.
  255%!  rb_update(+Tree, +Key, ?OldVal, +NewVal, -NewTree) is semidet.
  256%
  257%   Tree NewTree is tree Tree, but with   value  for Key associated with
  258%   NewVal. Fails if it cannot find Key in Tree.
  259
  260rb_update(t(Nil,OldTree), Key, OldVal, Val, NewTree2) =>
  261    NewTree2 = t(Nil,NewTree),
  262    update(OldTree, Key, OldVal, Val, NewTree).
  263
  264rb_update(t(Nil,OldTree), Key, Val, NewTree2) =>
  265    NewTree2 = t(Nil,NewTree),
  266    update(OldTree, Key, _, Val, NewTree).
  267
  268update(black(Left,Key0,Val0,Right), Key, OldVal, Val, NewTree) :-
  269    Left \= [],
  270    compare(Cmp,Key0,Key),
  271    (   Cmp == (=)
  272    ->  OldVal = Val0,
  273        NewTree = black(Left,Key0,Val,Right)
  274    ;   Cmp == (>)
  275    ->  NewTree = black(NewLeft,Key0,Val0,Right),
  276        update(Left, Key, OldVal, Val, NewLeft)
  277    ;   NewTree = black(Left,Key0,Val0,NewRight),
  278        update(Right, Key, OldVal, Val, NewRight)
  279    ).
  280update(red(Left,Key0,Val0,Right), Key, OldVal, Val, NewTree) :-
  281    compare(Cmp,Key0,Key),
  282    (   Cmp == (=)
  283    ->  OldVal = Val0,
  284        NewTree = red(Left,Key0,Val,Right)
  285    ;   Cmp == (>)
  286    ->  NewTree = red(NewLeft,Key0,Val0,Right),
  287        update(Left, Key, OldVal, Val, NewLeft)
  288    ;   NewTree = red(Left,Key0,Val0,NewRight),
  289        update(Right, Key, OldVal, Val, NewRight)
  290    ).
  291
  292%!  rb_apply(+Tree, +Key, :G, -NewTree) is semidet.
  293%
  294%   If the value associated  with  key  Key   is  Val0  in  Tree, and if
  295%   call(G,Val0,ValF) holds, then NewTree differs from Tree only in that
  296%   Key is associated with value  ValF  in   tree  NewTree.  Fails if it
  297%   cannot find Key in Tree, or if call(G,Val0,ValF) is not satisfiable.
  298
  299rb_apply(t(Nil,OldTree), Key, Goal, NewTree2) =>
  300    NewTree2 = t(Nil,NewTree),
  301    apply(OldTree, Key, Goal, NewTree).
  302
  303%apply(black('',_,_,''), _, _, _) :- !, fail.
  304apply(black(Left,Key0,Val0,Right), Key, Goal,
  305      black(NewLeft,Key0,Val,NewRight)) :-
  306    Left \= [],
  307    compare(Cmp,Key0,Key),
  308    (   Cmp == (=)
  309    ->  NewLeft = Left,
  310        NewRight = Right,
  311        call(Goal,Val0,Val)
  312    ;   Cmp == (>)
  313    ->  NewRight = Right,
  314        Val = Val0,
  315        apply(Left, Key, Goal, NewLeft)
  316    ;   NewLeft = Left,
  317        Val = Val0,
  318        apply(Right, Key, Goal, NewRight)
  319    ).
  320apply(red(Left,Key0,Val0,Right), Key, Goal,
  321      red(NewLeft,Key0,Val,NewRight)) :-
  322    compare(Cmp,Key0,Key),
  323    (   Cmp == (=)
  324    ->  NewLeft = Left,
  325        NewRight = Right,
  326        call(Goal,Val0,Val)
  327    ;   Cmp == (>)
  328    ->  NewRight = Right,
  329        Val = Val0,
  330        apply(Left, Key, Goal, NewLeft)
  331    ;   NewLeft = Left,
  332        Val = Val0,
  333        apply(Right, Key, Goal, NewRight)
  334    ).
  335
  336%!  rb_in(?Key, ?Value, +Tree) is nondet.
  337%
  338%   True when Key-Value is a key-value pair in red-black tree Tree. Same
  339%   as below, but does not materialize the pairs.
  340%
  341%        rb_visit(Tree, Pairs), member(Key-Value, Pairs)
  342%
  343%   Leaves a choicepoint, even  if  Key   is  instantiated;  to  avoid a
  344%   choicepoint, use rb_lookup/3.
  345
  346rb_in(Key, Val, t(_,T)) =>
  347    enum(Key, Val, T).
  348
  349enum(Key, Val, black(L,K,V,R)) :-
  350    L \= '',
  351    enum_cases(Key, Val, L, K, V, R).
  352enum(Key, Val, red(L,K,V,R)) :-
  353    enum_cases(Key, Val, L, K, V, R).
  354
  355enum_cases(Key, Val, L, _, _, _) :-
  356    enum(Key, Val, L).
  357enum_cases(Key, Val, _, Key, Val, _).
  358enum_cases(Key, Val, _, _, _, R) :-
  359    enum(Key, Val, R).
  360
  361
  362
  363                 /*******************************
  364                 *       TREE INSERTION         *
  365                 *******************************/
  366
  367% We don't use parent nodes, so we may have to fix the root.
  368
  369%!  rb_insert(+Tree, +Key, ?Value, -NewTree) is det.
  370%
  371%   Add an element with key Key and Value   to  the tree Tree creating a
  372%   new red-black tree NewTree. If Key is  a key in Tree, the associated
  373%   value is replaced by Value. See also rb_insert_new/4.
  374
  375:- det(rb_insert/4).  376rb_insert(t(Nil,Tree0),Key,Val,NewTree) =>
  377    NewTree = t(Nil,Tree),
  378    insert(Tree0,Key,Val,Nil,Tree).
  379
  380
  381insert(Tree0,Key,Val,Nil,Tree) :-
  382    insert2(Tree0,Key,Val,Nil,TreeI,_),
  383    fix_root(TreeI,Tree).
  384
  385%
  386% Cormen et al present the algorithm as
  387% (1) standard tree insertion;
  388% (2) from the viewpoint of the newly inserted node:
  389%     partially fix the tree;
  390%     move upwards
  391% until reaching the root.
  392%
  393% We do it a little bit different:
  394%
  395% (1) standard tree insertion;
  396% (2) move upwards:
  397%      when reaching a black node;
  398%        if the tree below may be broken, fix it.
  399% We take advantage of Prolog unification
  400% to do several operations in a single go.
  401%
  402
  403
  404
  405%
  406% actual insertion
  407%
  408insert2(black('',_,_,''), K, V, Nil, T, Status) :-
  409    !,
  410    T = red(Nil,K,V,Nil),
  411    Status = not_done.
  412insert2(red(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  413    (   K @< K0
  414    ->  NT = red(NL,K0,V0,R),
  415        insert2(L, K, V, Nil, NL, Flag)
  416    ;   K == K0
  417    ->  NT = red(L,K0,V,R),
  418        Flag = done
  419    ;   NT = red(L,K0,V0,NR),
  420        insert2(R, K, V, Nil, NR, Flag)
  421    ).
  422insert2(black(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  423    (   K @< K0
  424    ->  insert2(L, K, V, Nil, IL, Flag0),
  425        fix_left(Flag0, black(IL,K0,V0,R), NT, Flag)
  426    ;   K == K0
  427    ->  NT = black(L,K0,V,R),
  428        Flag = done
  429    ;   insert2(R, K, V, Nil, IR, Flag0),
  430        fix_right(Flag0, black(L,K0,V0,IR), NT, Flag)
  431    ).
  432
  433% We don't use parent nodes, so we may have to fix the root.
  434
  435%!  rb_insert_new(+Tree, +Key, ?Value, -NewTree) is semidet.
  436%
  437%   Add a new element with key Key and Value to the tree Tree creating a
  438%   new red-black tree NewTree. Fails if Key is a key in Tree.
  439
  440rb_insert_new(t(Nil,Tree0),Key,Val,NewTree) =>
  441    NewTree = t(Nil,Tree),
  442    insert_new(Tree0,Key,Val,Nil,Tree).
  443
  444insert_new(Tree0,Key,Val,Nil,Tree) :-
  445    insert_new_2(Tree0,Key,Val,Nil,TreeI,_),
  446    fix_root(TreeI,Tree).
  447
  448%
  449% actual insertion, copied from insert2
  450%
  451insert_new_2(black('',_,_,''), K, V, Nil, T, Status) :-
  452    !,
  453    T = red(Nil,K,V,Nil),
  454    Status = not_done.
  455insert_new_2(red(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  456    (   K @< K0
  457    ->  NT = red(NL,K0,V0,R),
  458        insert_new_2(L, K, V, Nil, NL, Flag)
  459    ;   K == K0
  460    ->  fail
  461    ;   NT = red(L,K0,V0,NR),
  462        insert_new_2(R, K, V, Nil, NR, Flag)
  463    ).
  464insert_new_2(black(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  465    (   K @< K0
  466    ->  insert_new_2(L, K, V, Nil, IL, Flag0),
  467        fix_left(Flag0, black(IL,K0,V0,R), NT, Flag)
  468    ;   K == K0
  469    ->  fail
  470    ;   insert_new_2(R, K, V, Nil, IR, Flag0),
  471        fix_right(Flag0, black(L,K0,V0,IR), NT, Flag)
  472    ).
  473
  474%
  475% make sure the root is always black.
  476%
  477fix_root(black(L,K,V,R),black(L,K,V,R)).
  478fix_root(red(L,K,V,R),black(L,K,V,R)).
  479
  480%
  481% How to fix if we have inserted on the left
  482%
  483fix_left(done,T,T,done) :- !.
  484fix_left(not_done,Tmp,Final,Done) :-
  485    fix_left(Tmp,Final,Done).
  486
  487%
  488% case 1 of RB: just need to change colors.
  489%
  490fix_left(black(red(Al,AK,AV,red(Be,BK,BV,Ga)),KC,VC,red(De,KD,VD,Ep)),
  491        red(black(Al,AK,AV,red(Be,BK,BV,Ga)),KC,VC,black(De,KD,VD,Ep)),
  492        not_done) :- !.
  493fix_left(black(red(red(Al,KA,VA,Be),KB,VB,Ga),KC,VC,red(De,KD,VD,Ep)),
  494        red(black(red(Al,KA,VA,Be),KB,VB,Ga),KC,VC,black(De,KD,VD,Ep)),
  495        not_done) :- !.
  496%
  497% case 2 of RB: got a knee so need to do rotations
  498%
  499fix_left(black(red(Al,KA,VA,red(Be,KB,VB,Ga)),KC,VC,De),
  500        black(red(Al,KA,VA,Be),KB,VB,red(Ga,KC,VC,De)),
  501        done) :- !.
  502%
  503% case 3 of RB: got a line
  504%
  505fix_left(black(red(red(Al,KA,VA,Be),KB,VB,Ga),KC,VC,De),
  506        black(red(Al,KA,VA,Be),KB,VB,red(Ga,KC,VC,De)),
  507        done) :- !.
  508%
  509% case 4 of RB: nothing to do
  510%
  511fix_left(T,T,done).
  512
  513%
  514% How to fix if we have inserted on the right
  515%
  516fix_right(done,T,T,done) :- !.
  517fix_right(not_done,Tmp,Final,Done) :-
  518    fix_right(Tmp,Final,Done).
  519
  520%
  521% case 1 of RB: just need to change colors.
  522%
  523fix_right(black(red(Ep,KD,VD,De),KC,VC,red(red(Ga,KB,VB,Be),KA,VA,Al)),
  524          red(black(Ep,KD,VD,De),KC,VC,black(red(Ga,KB,VB,Be),KA,VA,Al)),
  525          not_done) :- !.
  526fix_right(black(red(Ep,KD,VD,De),KC,VC,red(Ga,Ka,Va,red(Be,KB,VB,Al))),
  527          red(black(Ep,KD,VD,De),KC,VC,black(Ga,Ka,Va,red(Be,KB,VB,Al))),
  528          not_done) :- !.
  529%
  530% case 2 of RB: got a knee so need to do rotations
  531%
  532fix_right(black(De,KC,VC,red(red(Ga,KB,VB,Be),KA,VA,Al)),
  533          black(red(De,KC,VC,Ga),KB,VB,red(Be,KA,VA,Al)),
  534          done) :- !.
  535%
  536% case 3 of RB: got a line
  537%
  538fix_right(black(De,KC,VC,red(Ga,KB,VB,red(Be,KA,VA,Al))),
  539          black(red(De,KC,VC,Ga),KB,VB,red(Be,KA,VA,Al)),
  540          done) :- !.
  541%
  542% case 4 of RB: nothing to do.
  543%
  544fix_right(T,T,done).
  545
  546
  547%!  rb_delete(+Tree, +Key, -NewTree).
  548%!  rb_delete(+Tree, +Key, -Val, -NewTree).
  549%
  550%   Delete element with key Key from the  tree Tree, returning the value
  551%   Val associated with the key and a new tree NewTree.
  552%   Fails if Key is not in Tree.
  553
  554rb_delete(t(Nil,T), K, NewTree) =>
  555    NewTree = t(Nil,NT),
  556    delete(T, K, _, NT, _).
  557
  558rb_delete(t(Nil,T), K, V, NewTree) =>
  559    NewTree = t(Nil,NT),
  560    delete(T, K, V0, NT, _),
  561    V = V0.
  562
  563%
  564% I am afraid our representation is not as nice for delete
  565%
  566delete(red(L,K0,V0,R), K, V, NT, Flag) :-
  567    K @< K0,
  568    !,
  569    delete(L, K, V, NL, Flag0),
  570    fixup_left(Flag0,red(NL,K0,V0,R),NT, Flag).
  571delete(red(L,K0,V0,R), K, V, NT, Flag) :-
  572    K @> K0,
  573    !,
  574    delete(R, K, V, NR, Flag0),
  575    fixup_right(Flag0,red(L,K0,V0,NR),NT, Flag).
  576delete(red(L,_,V,R), _, V, OUT, Flag) :-
  577    % K == K0,
  578    delete_red_node(L,R,OUT,Flag).
  579delete(black(L,K0,V0,R), K, V, NT, Flag) :-
  580    K @< K0,
  581    !,
  582    delete(L, K, V, NL, Flag0),
  583    fixup_left(Flag0,black(NL,K0,V0,R),NT, Flag).
  584delete(black(L,K0,V0,R), K, V, NT, Flag) :-
  585    K @> K0,
  586    !,
  587    delete(R, K, V, NR, Flag0),
  588    fixup_right(Flag0,black(L,K0,V0,NR),NT, Flag).
  589delete(black(L,_,V,R), _, V, OUT, Flag) :-
  590    % K == K0,
  591    delete_black_node(L,R,OUT,Flag).
  592
  593%!  rb_del_min(+Tree, -Key, -Val, -NewTree)
  594%
  595%   Delete the least element from the tree  Tree, returning the key Key,
  596%   the value Val associated with the key and a new tree NewTree.
  597%   Fails if Tree is empty.
  598
  599rb_del_min(t(Nil,T), K, Val, NewTree) =>
  600    NewTree = t(Nil,NT),
  601    del_min(T, K, Val, Nil, NT, _).
  602
  603del_min(red(black('',_,_,_),K,V,R), K, V, Nil, OUT, Flag) :-
  604    !,
  605    delete_red_node(Nil,R,OUT,Flag).
  606del_min(red(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  607    del_min(L, K, V, Nil, NL, Flag0),
  608    fixup_left(Flag0,red(NL,K0,V0,R), NT, Flag).
  609del_min(black(black('',_,_,_),K,V,R), K, V, Nil, OUT, Flag) :-
  610    !,
  611    delete_black_node(Nil,R,OUT,Flag).
  612del_min(black(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  613    del_min(L, K, V, Nil, NL, Flag0),
  614    fixup_left(Flag0,black(NL,K0,V0,R),NT, Flag).
  615
  616
  617%!  rb_del_max(+Tree, -Key, -Val, -NewTree)
  618%
  619%   Delete the largest element from  the   tree  Tree, returning the key
  620%   Key, the value Val associated with the key and a new tree NewTree.
  621%   Fails if Tree is empty.
  622
  623
  624rb_del_max(t(Nil,T), K, Val, NewTree) =>
  625    NewTree = t(Nil,NT),
  626    del_max(T, K, Val, Nil, NT, _).
  627
  628del_max(red(L,K,V,black('',_,_,_)), K, V, Nil, OUT, Flag) :-
  629    !,
  630    delete_red_node(L,Nil,OUT,Flag).
  631del_max(red(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  632    del_max(R, K, V, Nil, NR, Flag0),
  633    fixup_right(Flag0,red(L,K0,V0,NR),NT, Flag).
  634del_max(black(L,K,V,black('',_,_,_)), K, V, Nil, OUT, Flag) :-
  635    !,
  636    delete_black_node(L,Nil,OUT,Flag).
  637del_max(black(L,K0,V0,R), K, V, Nil, NT, Flag) :-
  638    del_max(R, K, V, Nil, NR, Flag0),
  639    fixup_right(Flag0,black(L,K0,V0,NR), NT, Flag).
  640
  641delete_red_node(L1,L2,L1,done) :- L1 == L2, !.
  642delete_red_node(black('',_,_,''),R,R,done) :-  !.
  643delete_red_node(L,black('',_,_,''),L,done) :-  !.
  644delete_red_node(L,R,OUT,Done) :-
  645    delete_next(R,NK,NV,NR,Done0),
  646    fixup_right(Done0,red(L,NK,NV,NR),OUT,Done).
  647
  648delete_black_node(L1,L2,L1,not_done) :-         L1 == L2, !.
  649delete_black_node(black('',_,_,''),red(L,K,V,R),black(L,K,V,R),done) :- !.
  650delete_black_node(black('',_,_,''),R,R,not_done) :- !.
  651delete_black_node(red(L,K,V,R),black('',_,_,''),black(L,K,V,R),done) :- !.
  652delete_black_node(L,black('',_,_,''),L,not_done) :- !.
  653delete_black_node(L,R,OUT,Done) :-
  654    delete_next(R,NK,NV,NR,Done0),
  655    fixup_right(Done0,black(L,NK,NV,NR),OUT,Done).
  656
  657delete_next(red(black('',_,_,''),K,V,R),K,V,R,done) :-  !.
  658delete_next(black(black('',_,_,''),K,V,red(L1,K1,V1,R1)),
  659        K,V,black(L1,K1,V1,R1),done) :- !.
  660delete_next(black(black('',_,_,''),K,V,R),K,V,R,not_done) :- !.
  661delete_next(red(L,K,V,R),K0,V0,OUT,Done) :-
  662    delete_next(L,K0,V0,NL,Done0),
  663    fixup_left(Done0,red(NL,K,V,R),OUT,Done).
  664delete_next(black(L,K,V,R),K0,V0,OUT,Done) :-
  665    delete_next(L,K0,V0,NL,Done0),
  666    fixup_left(Done0,black(NL,K,V,R),OUT,Done).
  667
  668fixup_left(done,T,T,done).
  669fixup_left(not_done,T,NT,Done) :-
  670    fixup2(T,NT,Done).
  671
  672%
  673% case 1: x moves down, so we have to try to fix it again.
  674% case 1 -> 2,3,4 -> done
  675%
  676fixup2(black(black(Al,KA,VA,Be),KB,VB,
  677             red(black(Ga,KC,VC,De),KD,VD,
  678                 black(Ep,KE,VE,Fi))),
  679        black(T1,KD,VD,black(Ep,KE,VE,Fi)),done) :-
  680    !,
  681    fixup2(red(black(Al,KA,VA,Be),KB,VB,black(Ga,KC,VC,De)),
  682            T1,
  683            _).
  684%
  685% case 2: x moves up, change one to red
  686%
  687fixup2(red(black(Al,KA,VA,Be),KB,VB,
  688           black(black(Ga,KC,VC,De),KD,VD,
  689                 black(Ep,KE,VE,Fi))),
  690        black(black(Al,KA,VA,Be),KB,VB,
  691              red(black(Ga,KC,VC,De),KD,VD,
  692                  black(Ep,KE,VE,Fi))),done) :- !.
  693fixup2(black(black(Al,KA,VA,Be),KB,VB,
  694             black(black(Ga,KC,VC,De),KD,VD,
  695                   black(Ep,KE,VE,Fi))),
  696        black(black(Al,KA,VA,Be),KB,VB,
  697              red(black(Ga,KC,VC,De),KD,VD,
  698                  black(Ep,KE,VE,Fi))),not_done) :- !.
  699%
  700% case 3: x stays put, shift left and do a 4
  701%
  702fixup2(red(black(Al,KA,VA,Be),KB,VB,
  703           black(red(Ga,KC,VC,De),KD,VD,
  704                 black(Ep,KE,VE,Fi))),
  705        red(black(black(Al,KA,VA,Be),KB,VB,Ga),KC,VC,
  706            black(De,KD,VD,black(Ep,KE,VE,Fi))),
  707        done) :- !.
  708fixup2(black(black(Al,KA,VA,Be),KB,VB,
  709             black(red(Ga,KC,VC,De),KD,VD,
  710                   black(Ep,KE,VE,Fi))),
  711        black(black(black(Al,KA,VA,Be),KB,VB,Ga),KC,VC,
  712              black(De,KD,VD,black(Ep,KE,VE,Fi))),
  713        done) :- !.
  714%
  715% case 4: rotate left, get rid of red
  716%
  717fixup2(red(black(Al,KA,VA,Be),KB,VB,
  718           black(C,KD,VD,red(Ep,KE,VE,Fi))),
  719        red(black(black(Al,KA,VA,Be),KB,VB,C),KD,VD,
  720            black(Ep,KE,VE,Fi)),
  721        done).
  722fixup2(black(black(Al,KA,VA,Be),KB,VB,
  723             black(C,KD,VD,red(Ep,KE,VE,Fi))),
  724       black(black(black(Al,KA,VA,Be),KB,VB,C),KD,VD,
  725             black(Ep,KE,VE,Fi)),
  726       done).
  727
  728fixup_right(done,T,T,done).
  729fixup_right(not_done,T,NT,Done) :-
  730    fixup3(T,NT,Done).
  731
  732% case 1: x moves down, so we have to try to fix it again.
  733% case 1 -> 2,3,4 -> done
  734%
  735fixup3(black(red(black(Fi,KE,VE,Ep),KD,VD,
  736                 black(De,KC,VC,Ga)),KB,VB,
  737             black(Be,KA,VA,Al)),
  738        black(black(Fi,KE,VE,Ep),KD,VD,T1),done) :-
  739    !,
  740    fixup3(red(black(De,KC,VC,Ga),KB,VB,
  741               black(Be,KA,VA,Al)),T1,_).
  742
  743%
  744% case 2: x moves up, change one to red
  745%
  746fixup3(red(black(black(Fi,KE,VE,Ep),KD,VD,
  747                 black(De,KC,VC,Ga)),KB,VB,
  748           black(Be,KA,VA,Al)),
  749       black(red(black(Fi,KE,VE,Ep),KD,VD,
  750                 black(De,KC,VC,Ga)),KB,VB,
  751             black(Be,KA,VA,Al)),
  752       done) :- !.
  753fixup3(black(black(black(Fi,KE,VE,Ep),KD,VD,
  754                   black(De,KC,VC,Ga)),KB,VB,
  755             black(Be,KA,VA,Al)),
  756       black(red(black(Fi,KE,VE,Ep),KD,VD,
  757                 black(De,KC,VC,Ga)),KB,VB,
  758             black(Be,KA,VA,Al)),
  759       not_done):- !.
  760%
  761% case 3: x stays put, shift left and do a 4
  762%
  763fixup3(red(black(black(Fi,KE,VE,Ep),KD,VD,
  764                 red(De,KC,VC,Ga)),KB,VB,
  765           black(Be,KA,VA,Al)),
  766       red(black(black(Fi,KE,VE,Ep),KD,VD,De),KC,VC,
  767           black(Ga,KB,VB,black(Be,KA,VA,Al))),
  768       done) :- !.
  769fixup3(black(black(black(Fi,KE,VE,Ep),KD,VD,
  770                   red(De,KC,VC,Ga)),KB,VB,
  771             black(Be,KA,VA,Al)),
  772       black(black(black(Fi,KE,VE,Ep),KD,VD,De),KC,VC,
  773             black(Ga,KB,VB,black(Be,KA,VA,Al))),
  774       done) :- !.
  775%
  776% case 4: rotate right, get rid of red
  777%
  778fixup3(red(black(red(Fi,KE,VE,Ep),KD,VD,C),KB,VB,black(Be,KA,VA,Al)),
  779       red(black(Fi,KE,VE,Ep),KD,VD,black(C,KB,VB,black(Be,KA,VA,Al))),
  780       done).
  781fixup3(black(black(red(Fi,KE,VE,Ep),KD,VD,C),KB,VB,black(Be,KA,VA,Al)),
  782       black(black(Fi,KE,VE,Ep),KD,VD,black(C,KB,VB,black(Be,KA,VA,Al))),
  783       done).
  784
  785%!  rb_visit(+Tree, -Pairs) is det.
  786%
  787%   Pairs is an infix visit of tree Tree, where each element of Pairs is
  788%   of the form Key-Value.
  789
  790:- det(rb_visit/2).  791rb_visit(t(_,T),Lf) =>
  792    visit(T,[],Lf).
  793
  794visit(black('',_,_,_),L0,L) => L0 = L.
  795visit(red(L,K,V,R),L0,Lf) =>
  796    visit(L,[K-V|L1],Lf),
  797    visit(R,L0,L1).
  798visit(black(L,K,V,R),L0,Lf) =>
  799    visit(L,[K-V|L1],Lf),
  800    visit(R,L0,L1).
  801
  802:- meta_predicate map(?,2,?,?).  % this is required.
  803
  804%!  rb_map(+T, :Goal) is semidet.
  805%
  806%   True if call(Goal, Value) is true for all nodes in T.
  807
  808rb_map(t(Nil,Tree),Goal,NewTree2) =>
  809    NewTree2 = t(Nil,NewTree),
  810    map(Tree,Goal,NewTree,Nil).
  811
  812
  813map(black('',_,_,''),_,Nil,Nil) :- !.
  814map(red(L,K,V,R),Goal,red(NL,K,NV,NR),Nil) :-
  815    call(Goal,V,NV),
  816    !,
  817    map(L,Goal,NL,Nil),
  818    map(R,Goal,NR,Nil).
  819map(black(L,K,V,R),Goal,black(NL,K,NV,NR),Nil) :-
  820    call(Goal,V,NV),
  821    !,
  822    map(L,Goal,NL,Nil),
  823    map(R,Goal,NR,Nil).
  824
  825:- meta_predicate map(?,1).  % this is required.
  826
  827%!  rb_map(+Tree, :G, -NewTree) is semidet.
  828%
  829%   For all nodes Key in the tree Tree, if the value associated with key
  830%   Key is Val0 in tree Tree, and   if call(G,Val0,ValF) holds, then the
  831%   value  associated  with  Key  in   NewTree    is   ValF.   Fails  if
  832%   call(G,Val0,ValF) is not satisfiable for all Val0.
  833
  834rb_map(t(_,Tree),Goal) =>
  835    map(Tree,Goal).
  836
  837
  838map(black('',_,_,''),_) :- !.
  839map(red(L,_,V,R),Goal) :-
  840    call(Goal,V),
  841    !,
  842    map(L,Goal),
  843    map(R,Goal).
  844map(black(L,_,V,R),Goal) :-
  845    call(Goal,V),
  846    !,
  847    map(L,Goal),
  848    map(R,Goal).
  849
  850%!  rb_fold(:Goal, +Tree, +State0, -State).
  851%
  852%   Fold the given predicate  over  all   the  key-value  pairs in Tree,
  853%   starting with initial state State0  and   returning  the final state
  854%   State. Pred is called as
  855%
  856%       call(Pred, Key-Value, State1, State2)
  857%
  858%   Determinism depends on Goal.
  859
  860rb_fold(Pred, t(_,T), S1, S2) =>
  861    fold(T, Pred, S1, S2).
  862
  863fold(black(L,K,V,R), Pred) -->
  864    (   {L == ''}
  865    ->  []
  866    ;   fold_parts(Pred, L, K-V, R)
  867    ).
  868fold(red(L,K,V,R), Pred) -->
  869    fold_parts(Pred, L, K-V, R).
  870
  871fold_parts(Pred, L, KV, R) -->
  872    fold(L, Pred),
  873    call(Pred, KV),
  874    fold(R, Pred).
  875
  876%!  rb_clone(+TreeIn, -TreeOut, -Pairs) is det.
  877%
  878%   `Clone' the red-back tree TreeIn into a   new  tree TreeOut with the
  879%   same keys as the original but with all values set to unbound values.
  880%   Pairs is a list containing all new nodes as pairs K-V.
  881
  882:- det(rb_clone/3).  883rb_clone(t(Nil,T),TreeOut,Ns) =>
  884    TreeOut = t(Nil,NT),
  885    clone(T,Nil,NT,Ns,[]).
  886
  887clone(black('',_,_,''),Nil,Nil,Ns,Ns) :- !.
  888clone(red(L,K,_,R),Nil,red(NL,K,NV,NR),NsF,Ns0) :-
  889    clone(L,Nil,NL,NsF,[K-NV|Ns1]),
  890    clone(R,Nil,NR,Ns1,Ns0).
  891clone(black(L,K,_,R),Nil,black(NL,K,NV,NR),NsF,Ns0) :-
  892    clone(L,Nil,NL,NsF,[K-NV|Ns1]),
  893    clone(R,Nil,NR,Ns1,Ns0).
  894
  895%!  rb_partial_map(+Tree, +Keys, :G, -NewTree)
  896%
  897%   For all nodes Key in Keys, if the   value associated with key Key is
  898%   Val0 in tree Tree, and if   call(G,Val0,ValF)  holds, then the value
  899%   associated with Key in NewTree is ValF,   otherwise  it is the value
  900%   associated with the key in Tree. Fails if   Key  isn't in Tree or if
  901%   call(G,Val0,ValF) is not satisfiable for all   Val0 in Keys. Assumes
  902%   keys are sorted and not repeated (fails if this is not true).
  903
  904rb_partial_map(t(Nil,T0), Map, Goal, NewTree) =>
  905    NewTree = t(Nil,TF),
  906    partial_map(T0, Map, [], Nil, Goal, TF).
  907
  908partial_map(T,[],[],_,_,T) :- !.
  909partial_map(black('',_,_,_),Map,Map,Nil,_,Nil) :- !.
  910partial_map(red(L,K,V,R),Map,MapF,Nil,Goal,red(NL,K,NV,NR)) :-
  911    partial_map(L,Map,MapI,Nil,Goal,NL),
  912    (   MapI == []
  913    ->  NR = R, NV = V, MapF = []
  914    ;   MapI = [K1|MapR],
  915        (   K == K1
  916        ->  (   call(Goal,V,NV)
  917            ->  true
  918            ;   NV = V
  919            ),
  920            MapN = MapR
  921        ;   NV = V,
  922            MapN = MapI
  923        ),
  924        partial_map(R,MapN,MapF,Nil,Goal,NR)
  925    ).
  926partial_map(black(L,K,V,R),Map,MapF,Nil,Goal,black(NL,K,NV,NR)) :-
  927    partial_map(L,Map,MapI,Nil,Goal,NL),
  928    (   MapI == []
  929    ->  NR = R, NV = V, MapF = []
  930    ;   MapI = [K1|MapR],
  931        (   K == K1
  932        ->  (   call(Goal,V,NV)
  933            ->  true
  934            ;   NV = V
  935            ),
  936            MapN = MapR
  937        ;   NV = V,
  938            MapN = MapI
  939        ),
  940        partial_map(R,MapN,MapF,Nil,Goal,NR)
  941    ).
  942
  943
  944%!  rb_keys(+Tree, -Keys) is det.
  945%
  946%   Keys is unified with an ordered list   of  all keys in the Red-Black
  947%   tree Tree.
  948
  949:- det(rb_keys/2).  950rb_keys(t(_,T),Lf) =>
  951    keys(T,[],Lf).
  952
  953keys(black('',_,_,''),L,L) :- !.
  954keys(red(L,K,_,R),L0,Lf) :-
  955    keys(L,[K|L1],Lf),
  956    keys(R,L0,L1).
  957keys(black(L,K,_,R),L0,Lf) :-
  958    keys(L,[K|L1],Lf),
  959    keys(R,L0,L1).
  960
  961
  962%!  list_to_rbtree(+List, -Tree) is det.
  963%
  964%   Tree is the red-black tree  corresponding   to  the mapping in List,
  965%   which should be a list of Key-Value   pairs. List should not contain
  966%   more than one entry for each distinct key, but this is not validated
  967%   by list_to_rbtree/2.
  968
  969:- det(list_to_rbtree/2).  970list_to_rbtree(List, T) :-
  971    sort(List,Sorted),
  972    ord_list_to_rbtree(Sorted, T).
  973
  974%!  ord_list_to_rbtree(+List, -Tree) is det.
  975%
  976%   Tree is the red-black tree  corresponding   to  the  mapping in list
  977%   List, which should be a list  of   Key-Value  pairs. List should not
  978%   contain more than one entry for each   distinct key, but this is not
  979%   validated by ord_list_to_rbtree/2. List is assumed
  980%   to be sorted according to the standard order of terms.
  981
  982:- det(ord_list_to_rbtree/2).  983ord_list_to_rbtree([], Tree) =>
  984    Tree = t(Nil,Nil),
  985    Nil = black('', _, _, '').
  986ord_list_to_rbtree([K-V], Tree), nonvar(K) =>
  987    Tree = t(Nil,black(Nil,K,V,Nil)),
  988    Nil = black('', _, _, '').
  989ord_list_to_rbtree(List, Tree2) =>
  990    Tree2 = t(Nil,Tree),
  991    Nil = black('', _, _, ''),
  992    Ar =.. [seq|List],
  993    functor(Ar,_,L),
  994    Height is truncate(log(L)/log(2)),
  995    construct_rbtree(1, L, Ar, Height, Nil, Tree).
  996
  997construct_rbtree(L, M, _, _, Nil, Nil) :- M < L, !.
  998construct_rbtree(L, L, Ar, Depth, Nil, Node) :-
  999    !,
 1000    arg(L, Ar, K-Val),
 1001    build_node(Depth, Nil, K, Val, Nil, Node).
 1002construct_rbtree(I0, Max, Ar, Depth, Nil, Node) :-
 1003    I is (I0+Max)//2,
 1004    arg(I, Ar, K-Val),
 1005    build_node(Depth, Left, K, Val, Right, Node),
 1006    I1 is I-1,
 1007    NewDepth is Depth-1,
 1008    construct_rbtree(I0, I1, Ar, NewDepth, Nil, Left),
 1009    I2 is I+1,
 1010    construct_rbtree(I2, Max, Ar, NewDepth, Nil, Right).
 1011
 1012build_node( 0, Left, K, Val, Right, red(Left, K, Val, Right)) :- !.
 1013build_node( _, Left, K, Val, Right, black(Left, K, Val, Right)).
 1014
 1015
 1016%!  rb_size(+Tree, -Size) is det.
 1017%
 1018%   Size is the number of elements in Tree.
 1019
 1020:- det(rb_size/2). 1021rb_size(t(_,T),Size) =>
 1022    size(T,0,Size).
 1023
 1024size(black('',_,_,_),Sz,Sz) :- !.
 1025size(red(L,_,_,R),Sz0,Szf) :-
 1026    Sz1 is Sz0+1,
 1027    size(L,Sz1,Sz2),
 1028    size(R,Sz2,Szf).
 1029size(black(L,_,_,R),Sz0,Szf) :-
 1030    Sz1 is Sz0+1,
 1031    size(L,Sz1,Sz2),
 1032    size(R,Sz2,Szf).
 1033
 1034%!  is_rbtree(@Term) is semidet.
 1035%
 1036%   True if Term is a valid Red-Black   tree. Processes the entire tree,
 1037%   checking the coloring of the nodes, the  balance and the ordering of
 1038%   keys. It does _not_ validate that keys are sufficiently instantiated
 1039%   to ensure the tree remains valid if a key is further instantiated.
 1040
 1041is_rbtree(X), var(X) =>
 1042    fail.
 1043is_rbtree(t(Nil,Nil)) => true.
 1044is_rbtree(t(_,T)) =>
 1045    Err = error(_,_),
 1046    catch(check_rbtree(T), Err, is_rbtree_error(Err)).
 1047
 1048is_rbtree_error(Err), Err = error(resource_error(_),_) => throw(Err).
 1049is_rbtree_error(_) => fail.
 1050
 1051%
 1052% This code checks if a tree is ordered and a rbtree
 1053%
 1054% TODO: Use (?=)/2 to verify that pairwise keys are strictly
 1055%       ordered, no matter how the keys become instantiated.
 1056%       This is not a complete test; to be completely safe, all
 1057%       use of compare/3 (and (@<)/2 etc) would need to also
 1058%       use (?=)/2, which would be expensive.
 1059
 1060check_rbtree(black(L,K,_,R)) =>
 1061    find_path_blacks(L, 0, Bls),
 1062    check_rbtree(L,-inf,K,Bls),
 1063    check_rbtree(R,K,+inf,Bls).
 1064check_rbtree(Node), Node = red(_,_,_,_) =>
 1065    domain_error(rb_black, Node).
 1066
 1067
 1068find_path_blacks(black('',_,_,''), Bls0, Bls) => Bls = Bls0.
 1069find_path_blacks(black(L,_,_,_), Bls0, Bls) =>
 1070    Bls1 is Bls0+1,
 1071    find_path_blacks(L, Bls1, Bls).
 1072find_path_blacks(red(L,_,_,_), Bls0, Bls) =>
 1073    find_path_blacks(L, Bls0, Bls).
 1074
 1075check_rbtree(black('',_,_,''),Min,Max,Bls0) =>
 1076    check_height(Bls0,Min,Max).
 1077check_rbtree(red(L,K,_,R),Min,Max,Bls) =>
 1078    check_val(K,Min,Max),
 1079    check_red_child(L),
 1080    check_red_child(R),
 1081    check_rbtree(L,Min,K,Bls),
 1082    check_rbtree(R,K,Max,Bls).
 1083check_rbtree(black(L,K,_,R),Min,Max,Bls0) =>
 1084    check_val(K,Min,Max),
 1085    Bls is Bls0-1,
 1086    check_rbtree(L,Min,K,Bls),
 1087    check_rbtree(R,K,Max,Bls).
 1088
 1089check_height(0,_,_) => true.
 1090check_height(Bls0,Min,Max) =>
 1091    throw(error(rbtree(balance(Bls0, Min, Max)), _)).
 1092
 1093check_val(K, Min, Max), (K @> Min ; Min == -inf), (K @< Max ; Max == +inf) =>
 1094    true.
 1095check_val(K, Min, Max) =>
 1096    throw(error(rbtree(order(K, Min, Max)), _)).
 1097
 1098check_red_child(black(_,_,_,_)) => true.
 1099check_red_child(Node), Node = red(_,_,_,_) =>
 1100    domain_error(rb_black, Node).
 1101
 1102
 1103		 /*******************************
 1104		 *            MESSAGES		*
 1105		 *******************************/
 1106
 1107:- multifile
 1108    prolog:error_message//1. 1109
 1110prolog:error_message(rbtree(balance(Bls0, Min, Max))) -->
 1111    [ 'Unbalance ~d between ~w and ~w'-[Bls0,Min,Max] ].
 1112prolog:error_message(rbtree(order(K, Min, Max))) -->
 1113    [ 'not ordered: ~w not between ~w and ~w'-[K,Min,Max] ]