avl_custom

adjust(no, Oldree, _, Oldree, no).

adjust(yes, node(Key,Val,B0,L,R), LoR, NewTree, WhatHasChanged) :-
    table(B0, LoR, B1, WhatHasChanged, ToBeRebalanced),
    rebalance(ToBeRebalanced, node(Key,Val,B0,L,R), B1, NewTree, _, _).

avl(-2, K, V, L, R, NewTree) :-
    avl_geq(node(K, V, -1, L, R), NewTree, _RealChange).

avl(-1, K, V, L, R, node(K, V, -1, L, R)).

avl(0, K, V, L, R, node(K, V, 0, L, R)).

avl(1, K, V, L, R, node(K, V, 1, L, R)).

avl(2, K, V, L, R, NewTree) :-
    avl_geq(node(K, V, 1, L, R), NewTree, _RealChange).

avl_change(Key, node(K,V,B,L,R), Val, node(K,NV,B,NL,NR), NVal) :-
    compare(Rel, Key, K),
    avl_change(Rel, Key, V, L, R, Val, NV, NL, NR, NVal).

avl_change(=, _, Val, L, R, Val, NVal, L, R, NVal).

avl_change(<, Key, V, L, R, Val, V, NL, R, NVal) :-
    avl_change(Key, L, Val, NL, NVal).

avl_change(>, Key, V, L, R, Val, V, L, NR, NVal) :-
    avl_change(Key, R, Val, NR, NVal).

avl_del_max(Tree, Key, Val, NewTree) :-
    avl_del_max(Tree, Key, Val, NewTree, _Diff).

avl_del_max(node(Key,Val,_B,L,empty), Key, Val, L, 1) :- !.

avl_del_max(node(K,V,B,L,R), Key, Val, NewTree, Diff) :-
    avl_del_max(R, Key, Val, NewR, RightDiff),
    deladjust(RightDiff, node(K,V,B,L,NewR), right, NewTree, Diff).

avl_del_min(Tree, Key, Val, NewTree) :-
    avl_del_min(Tree, Key, Val, NewTree, _Diff).

avl_del_min(node(Key,Val,_B,empty,R), Key, Val, R, 1) :- !.

avl_del_min(node(K,V,B,L,R), Key, Val, NewTree, Diff) :-
    avl_del_min(L, Key, Val, NewL, LeftDiff),
    deladjust(LeftDiff, node(K,V,B,NewL,R), left, NewTree, Diff).

avl_delete(Key, A0, Value, A) :-
    delete(A0, Key, Value, A, _).

avl_domain(AVL, List) :-
    avl_domain(AVL, List, []).

avl_domain(empty, List, List).

avl_domain(node(Key,_,_,L,R), List, Rest) :-
    avl_domain(L, List, [Key|More]),
    avl_domain(R, More, Rest).

avl_fetch(Key, AVL) :- avl_fetch(Key, AVL, _).

avl_fetch(Key, AVL, Val) :-
    must_be_avl(AVL, avl_fetch(Key, AVL, Val), 2),
    AVL = node(K,V,_,L,R),
    compare(Rel, Key, K),
    avl_fetch(Rel, Key, V, L, R, Val).

avl_fetch(=, _, Val, _, _, Val).

avl_fetch(<, Key, _, Tree, _, Val) :-
    avl_fetch(Key, Tree, Val).

avl_fetch(>, Key, _, _, Tree, Val) :-
    avl_fetch(Key, Tree, Val).

avl_geq(node(A,VA,1,Alpha,node(B,VB,1,Beta,Gamma)),
    node(B,VB,0,node(A,VA,0,Alpha,Beta),Gamma), 1) :- !.

avl_geq(node(A,VA,1,Alpha,node(B,VB,0,Beta,Gamma)),
    node(B,VB,-1,node(A,VA,1,Alpha,Beta),Gamma), 0) :- !.

avl_geq(node(B,VB,-1,node(A,VA,-1,Alpha,Beta),Gamma),
    node(A,VA,0,Alpha,node(B,VB,0,Beta,Gamma)), 1) :- !.

avl_geq(node(B,VB,-1,node(A,VA,0,Alpha,Beta),Gamma),
    node(A,VA,1,Alpha,node(B,VB,-1,Beta,Gamma)), 0) :- !.

avl_geq(node(A,VA,1,Alpha,node(B,VB,-1,node(X,VX,B1,Beta,Gamma),Delta)),
    node(X,VX,0,node(A,VA,B2,Alpha,Beta),node(B,VB,B3,Gamma,Delta)), 1) :- !,
    table2(B1, B2, B3).

avl_geq(node(B,VB,-1,node(A,VA,1,Alpha,node(X,VX,B1,Beta,Gamma)),Delta),
    node(X,VX,0,node(A,VA,B2,Alpha,Beta),node(B,VB,B3,Gamma,Delta)), 1) :- !,
    table2(B1, B2, B3).

avl_height(empty, 0).

avl_height(node(_,_,-1,L,_), Height) :-
    avl_height(L, HeightL),
    Height is HeightL + 1.

avl_height(node(_,_,0,L,_), Height) :-
    avl_height(L, HeightL),
    Height is HeightL + 1.

avl_height(node(_,_,1,_,R), Height) :-
    avl_height(R, HeightR),
    Height is HeightR + 1.

avl_map(Pred, T) :-
    avl_map_(T, Pred).

avl_map(Pred, T0, T) :-
    avl_map_(T0, Pred, T).

avl_map_(empty, _).

avl_map_(node(_,Val,_,L,R), Pred) :-
    avl_map_(L, Pred),
    call(Pred, Val),
    avl_map_(R, Pred).

avl_map_(empty, _, empty).

avl_map_(node(Key,Val,B,L0,R0), Pred, node(Key,Ans,B,L1,R1)) :-
    avl_map_(L0, Pred, L1),
    call(Pred, Val, Ans),
    avl_map_(R0, Pred, R1).

avl_max(AVL, Key) :- avl_max(AVL, Key, _).

avl_max(node(K,V,_,_,R), Key, Val) :-
    avl_max(R, K, V, Key, Val).

avl_max(empty, K, V, K, V).

avl_max(node(K,V,_,_,R), _, _, Key, Val) :-
    avl_max(R, K, V, Key, Val).

avl_member(Key, AVL) :- avl_member(Key, AVL, _).

avl_member(Key, node(_,_,_,L,_), Val) :-
    avl_member(Key, L, Val).

avl_member(Key, node(Key,Val,_,_,_), Val).

avl_member(Key, node(_,_,_,_,R), Val) :-
    avl_member(Key, R, Val).

avl_min(AVL, Key) :- avl_min(AVL, Key, _).

avl_min(node(K,V,_,L,_), Key, Val) :-
    avl_min(L, K, V, Key, Val).

avl_min(empty, K, V, K, V).

avl_min(node(K,V,_,L,_), _, _, Key, Val) :-
    avl_min(L, K, V, Key, Val).

avl_next(Key, AVL, Knext) :- avl_next(Key, AVL, Knext, _).

avl_next(Key, AVL, Knext, Vnext) :-
    must_be_avl(AVL, avl_next(Key, AVL, Knext, Vnext), 2),
    AVL = node(K,V,_,L,R),
    compare(Rel, Key, K),
    avl_next(Rel, Key, K, V, L, R, Knext, Vnext).

avl_next(=, _, _, _, _, R, Knext, Vnext) :-
    avl_min(R, Knext, Vnext).

avl_next(<, Key, K, V, L, _, Knext, Vnext) :-
    ( avl_next(Key, L, Knext, Vnext)
    -> true
    ; Knext = K,
    Vnext = V
).

avl_next(>, Key, _, _, _, R, Knext, Vnext) :-
    avl_next(Key, R, Knext, Vnext).

avl_prev(Key, AVL, Kprev) :- avl_prev(Key, AVL, Kprev, _).

avl_prev(Key, AVL, Kprev, Vprev) :-
    must_be_avl(AVL, avl_prev(Key, AVL, Kprev, Vprev), 2),
    AVL = node(K,V,_,L,R),
    compare(Rel, Key, K),
    avl_prev(Rel, Key, K, V, L, R, Kprev, Vprev).

avl_prev(=, _, _, _, L, _, Kprev, Vprev) :-
    avl_max(L, Kprev, Vprev).

avl_prev(<, Key, _, _, L, _, Kprev, Vprev) :-
    avl_prev(Key, L, Kprev, Vprev).

avl_prev(>, Key, K, V, _, R, Kprev, Vprev) :-
    ( avl_prev(Key, R, Kprev, Vprev)
    -> true
    ; Kprev = K,
    Vprev = V
).

avl_range(AVL, List) :-
    avl_range(AVL, List, []).

avl_range(empty, List, List).

avl_range(node(_,Value,_,L,R), List, Rest) :-
    avl_range(L, List, [Value|More]),
    avl_range(R, More, Rest).

avl_shrinkage(node(_K, _V, Bal, _L, _R), DiffBefore, RealDiff) :-
    % This seems to be the exact calculation performed by the SICStus implementation.
    % I have no idea what this is supposed to accomplish.
    RealDiff is \Bal /\ DiffBefore.

avl_size(empty, 0).

avl_size(node(_,_,_,L,R), Size) :-
    avl_size(L, SizeL),
    avl_size(R, SizeR),
    Size is SizeL + SizeR + 1.

avl_store(Key, A0, Value, A) :-
    insert(A0, Key, Value, A, _).

avl_to_list(AVL, List) :-
    avl_to_list(AVL, List, []).

avl_to_list(node(Key,Val,_,L,R), List, Rest) :-
    avl_to_list(L, List, [Key-Val|More]),
    avl_to_list(R, More, Rest).

avl_to_list(empty, List, List).

balance(=, 0).

balance(<,-1).

balance(>, 1).

deladjust(0, OldTree, _, OldTree, 0).

deladjust(1, node(Key,Val,B0,L,R), LoR, NewTree, RealChange) :-
    deltable(B0, LoR, B1, Diff, ToBeRebalanced),
    rebalance(ToBeRebalanced, node(Key,Val,B0,L,R), B1, NewTree, Diff, RealChange).

delete(node(Key,Val,B,L,R), K, V, NewTree, Diff) :-
    compare(Rel, K, Key),
    delete(Rel, node(Key,Val,B,L,R), K, V, NewTree, Diff).

delete(=, node(Key,Val,_B,empty,R), Key, Val, R, 1) :- !.

delete(=, node(Key,Val,_B,L,empty), Key, Val, L, 1) :- !.

delete(=, node(Key,Val,1,L,R), Key, Val, NewTree, Diff) :-
    % Rh tree is deeper, so rotate from R to L
    avl_del_min(R, K, V, NewR, RightDiff),
    deladjust(RightDiff, node(K,V,1,L,NewR), right, NewTree, Diff), !.

delete(=, node(Key,Val,B,L,R), Key, Val, NewTree, Diff) :-
    % Rh tree is not deeper, so rotate from L to R
    avl_del_max(L, K, V, NewL, LeftDiff),
    deladjust(LeftDiff, node(K,V,B,NewL,R), left, NewTree, Diff), !.

delete(<, node(Key,Val,B,L,R), K, V, NewTree, Diff) :-
    delete(L, K, V, NewL, LeftDiff),
    deladjust(LeftDiff, node(Key,Val,B,NewL,R), left, NewTree, Diff).

delete(>, node(Key,Val,B,L,R), K, V, NewTree, Diff) :-
    delete(R, K, V, NewR, RightDiff),
    deladjust(RightDiff, node(Key,Val,B,L,NewR), right, NewTree, Diff).

deltable( 0 , right , -1 , 0 , no ) :- !.

deltable( 0 , left , 1 , 0 , no ) :- !.

deltable(-1 , right , 0 , 1 , yes ) :- !.

deltable(-1 , left , 0 , 1 , no ) :- !.

deltable( 1 , right , 0 , 1 , no ) :- !.

deltable( 1 , left , 0 , 1 , yes ) :- !.

empty_avl(empty).

insert(empty, Key, Val, node(Key,Val,0,empty,empty), yes).

insert(node(Key,Val,B,L,R), K, V, NewTree, WhatHasChanged) :-
    compare(Rel, K, Key),
    insert(Rel, node(Key,Val,B,L,R), K, V, NewTree, WhatHasChanged).

insert(=, node(Key,_,B,L,R), _, V, node(Key,V,B,L,R), no).

insert(<, node(Key,Val,B,L,R), K, V, NewTree, WhatHasChanged) :-
    insert(L, K, V, NewL, LeftHasChanged),
    adjust(LeftHasChanged, node(Key,Val,B,NewL,R), left, NewTree, WhatHasChanged).

insert(>, node(Key,Val,B,L,R), K, V, NewTree, WhatHasChanged) :-
    insert(R, K, V, NewR, RightHasChanged),
    adjust(RightHasChanged, node(Key,Val,B,L,NewR), right, NewTree, WhatHasChanged).

is_avl(AVL) :-
    is_avl(AVL, _Min, _Max, _Depth).

is_avl(empty,X,X,0) :- !.

is_avl(node(K,_,0,empty,empty),K,K,1) :- !, ground(K).

is_avl(node(K,_,1,empty,node(RK,_,0,empty,empty)),K,RK,2) :-
    % Ensure right side Key is 'greater' than K
    !,
    ground((K,RK)),
    K @< RK.

is_avl(node(K,_,-1,node(LK,_,0,empty,empty),empty),LK,K,2) :-
    % Ensure left side Key is 'less' than K
    !,
    ground((LK,K)),
    LK @< K.

is_avl(node(K,_,B,L,R),Min,Max,Depth) :-
    is_avl(L,Min,LMax,LDepth),
    is_avl(R,RMin,Max,RDepth),
    % Ensure Balance matches depth
    compare(Rel,RDepth,LDepth),
    balance(Rel,B),
    % Ensure ordering
    ground((LMax,K,RMin)),
    LMax @< K,
    K @< RMin,
    Depth is max(LDepth, RDepth)+1.

list_to_avl(List, AVL) :-
    ( List = [] -> AVL = empty
    ; keysort(List, Sorted),
    ( ord_pairs(Sorted)
    -> length(Sorted, N),
    list_to_avl(N, Sorted, [], _, AVL)
    ; illarg(domain(list, unique_key_pairs), list_to_avl(List, AVL), 1)
)
).

list_to_avl(1, [K-V|More], More, 1, node(K,V,0,empty,empty)) :- !.

list_to_avl(2, [K1-V1,K2-V2|More], More, 2, node(K1,V1,1,empty,node(K2,V2,0,empty,empty))) :- !.

list_to_avl(N, List, More, Depth, node(K,V,Balance,L,R)) :-
    N0 is N - 1,
    LN is N0 div 2,
    Rem is N0 mod 2,
    RN is LN + Rem,
    list_to_avl(LN, List, [K-V|Upper], LDepth, L),
    list_to_avl(RN, Upper, More, RDepth, R),
    Depth is RDepth + 1,
    compare(B, RDepth, LDepth), balance(B, Balance).

must_be_avl(Term, _Goal, _ArgNo) :- Term == empty, !.

must_be_avl(Term, _Goal, _ArgNo) :- compound(Term), functor(Term, node, 5), !.

must_be_avl(Term, Goal, ArgNo) :- illarg(force_type(avl), Goal, ArgNo, Term).

ord_list_to_avl(Sorted, AVL) :-
    ( Sorted = [] -> AVL = empty
    ; ( ord_pairs(Sorted)
    -> length(Sorted, N),
    list_to_avl(N, Sorted, [], _, AVL)
    ; illarg(domain(list, key_ordered_pairs), ord_list_to_avl(Sorted, AVL), 1)
)
).

ord_pairs([K-_V|Rest]) :-
    ord_pairs(Rest, K).

ord_pairs([], _K).

ord_pairs([K-_V|Rest], K0) :-
    K0 @< K,
    ord_pairs(Rest, K).

portray_avl(AVL) :-
    format('AVL{', []),
    portray_avl_leftmost(AVL),
    format('}', []).

portray_avl_leftmost(empty).

portray_avl_leftmost(node(K,V,B,L,R)) :-
    (L == empty
    -> true
    ; portray_avl_leftmost(L),
    format(",", [])
    ),
    print(K),
    (B == 0 -> format("->", []) ; format("->*", [])),
    print(V),
    portray_avl_rest(R).

portray_avl_rest(empty).

portray_avl_rest(node(K,V,B,L,R)) :-
    portray_avl_rest(L),
    format(",", []),
    print(K),
    (B == 0 -> format("->", []) ; format("->*", [])),
    print(V),
    portray_avl_rest(R).

rebalance(no, node(K,V,_,L,R), B, node(K,V,B,L,R), Changed, Changed).

rebalance(yes, OldTree, _, NewTree, _, RealChange) :-
    avl_geq(OldTree, NewTree, RealChange).

table( 0 , left , -1 , yes , no ) :- !.

table( 0 , right , 1 , yes , no ) :- !.

table(-1 , left , 0 , no , yes ) :- !.

table(-1 , right , 0 , no , no ) :- !.

table( 1 , left , 0 , no , no ) :- !.

table( 1 , right , 0 , no , yes ) :- !.

table2(-1, 0, 1).

table2( 1,-1, 0).

table2( 0, 0, 0).