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]).
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(,,), 99 rb_map(,), 100 rb_partial_map(,,,), 101 rb_apply(,,,), 102 rb_fold(,,,). 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*/
133:- det(rb_new/1). 134rb_new(t(Nil,Nil)) :- 135 Nil = black('',_,_,'').
141rb_empty(t(Nil,Nil)) :-
142 Nil = black('',_,_,'').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).
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).
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).
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 ).
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 ).
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 ).
call(G,Val0,ValF) holds, then NewTree differs from Tree only in that
Key is associated with value ValF in tree NewTree. Fails if it
cannot find Key in Tree, or if call(G,Val0,ValF) is not satisfiable.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 ).
rb_visit(Tree, Pairs), member(Key-Value, Pairs)
Leaves a choicepoint, even if Key is instantiated; to avoid a choicepoint, use rb_lookup/3.
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.
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.
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).
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).
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).
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).
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(,,,). % this is required.
call(Goal, Value) is true for all nodes in T.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(,). % this is required.
call(G,Val0,ValF) holds, then the
value associated with Key in NewTree is ValF. Fails if
call(G,Val0,ValF) is not satisfiable for all Val0.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).
call(Pred, Key-Value, State1, State2)
Determinism depends on Goal.
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).
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).
call(G,Val0,ValF) holds, then the value
associated with Key in NewTree is ValF, otherwise it is the value
associated with the key in Tree. Fails if Key isn't in Tree or if
call(G,Val0,ValF) is not satisfiable for all Val0 in Keys. Assumes
keys are sorted and not repeated (fails if this is not true).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 ).
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).
969:- det(list_to_rbtree/2). 970list_to_rbtree(List, T) :- 971 sort(List,Sorted), 972 ord_list_to_rbtree(Sorted, T).
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)).
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).
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 1110prologerror_message(rbtree(balance(Bls0, Min, Max))) --> 1111 [ 'Unbalance ~d between ~w and ~w'-[Bls0,Min,Max] ]. 1112prologerror_message(rbtree(order(K, Min, Max))) --> 1113 [ 'not ordered: ~w not between ~w and ~w'-[K,Min,Max] ]
Red black trees
Red-Black trees are balanced search binary trees. They are named because nodes can be classified as either red or black. The code we include is based on "Introduction to Algorithms", second edition, by Cormen, Leiserson, Rivest and Stein. The library includes routines to insert, lookup and delete elements in the tree.
A Red black tree is represented as a term
t(Nil, Tree), where Nil is the Nil-node, a node shared for each nil-node in the tree. Any node has the formcolour(Left, Key, Value, Right), where colour is one ofredorblack.