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