## binary-map-g.pkg
#
# Normally
# src/lib/src/red-black-map-g.pkg# is preferred.
# Compiled by:
# src/lib/std/standard.lib# This code was adapted from Stephen Adams' binary tree implementation
# of applicative integer sets.
#
# Copyright 1992 Stephen Adams.
#
# This software may be used freely provided that:
# 1. This copyright notice is attached to any copy, derived work,
# or work including all or part of this software.
# 2. Any derived work must contain a prominent notice stating that
# it has been altered from the original.
#
#
# Name (s): Stephen Adams.
# Department, Institution: Electronics & Computer Science,
# University of Southampton
# Address: Electronics & Computer Science
# University of Southampton
# Southampton SO9 5NH
# Great Britian
# E-mail: sra@ecs.soton.ac.uk
#
# Comments:
#
# 1. The implementation is based on Binary search trees of Bounded
# Balance, similar to Nievergelt & Reingold, SIAM J. Computing
# 2 (1), March 1973. The main advantage of these trees is that
# they keep the size of the tree in the node, giving a constant
# time size operation.
#
# 2. The bounded balance criterion is simpler than N&R's alpha.
# Simply, one subtree must not have more than `weight' times as
# many elements as the opposite subtree. Rebalancing is
# guaranteed to reinstate the criterion for weight>2.23, but
# the occasional incorrect behaviour for weight=2 is not
# detrimental to performance.
#
## THIS DERIVED WORK HAS BEEN ALTERED FROM THE ORIGINAL
generic package binary_map_g (k: Key ) # Key is from src/lib/src/key.api: (weak)
Map # Map is from src/lib/src/map.api{
package key = k;
#
# weight = 3
# fun wt i = weight * i
fun wt (i: Int)
=
i + i + i;
Map X
= EMPTY
| TREE_NODE {
key: k::Key,
value: X,
count: Int,
left: Map(X),
right: Map(X)
};
empty = EMPTY;
fun is_empty EMPTY => TRUE;
is_empty _ => FALSE;
end;
fun debug_print (map, print_key, print_val) = 0; # Placeholder
fun all_invariants_hold map = TRUE; # Placeholder
fun vals_count EMPTY => 0;
vals_count (TREE_NODE { count, ... } ) => count;
end;
# Return the first item in the map
# or NULL if it is empty:
#
fun first_val_else_null EMPTY => NULL;
first_val_else_null (TREE_NODE { value, left=>EMPTY, ... } ) => THE value;
first_val_else_null (TREE_NODE { left, ... } ) => first_val_else_null left;
end;
# Return the first item in the map
# and its key, or NULL if it is empty:
#
fun first_keyval_else_null EMPTY => NULL;
first_keyval_else_null (TREE_NODE { key, value, left=>EMPTY, ... } ) => THE (key, value);
first_keyval_else_null (TREE_NODE { left, ... } ) => first_keyval_else_null left;
end;
# Return the last item in the map
# or NULL if it is empty:
#
fun last_val_else_null EMPTY => NULL;
last_val_else_null (TREE_NODE { value, right=>EMPTY, ... } ) => THE value;
last_val_else_null (TREE_NODE { right, ... } ) => last_val_else_null right;
end;
# Return the last item in the map
# and its key, or NULL if it is empty:
#
fun last_keyval_else_null EMPTY => NULL;
last_keyval_else_null (TREE_NODE { key, value, right=>EMPTY, ... } ) => THE (key, value);
last_keyval_else_null (TREE_NODE { right, ... } ) => last_keyval_else_null right;
end;
stipulate
fun node_count (k, v, EMPTY, EMPTY) => TREE_NODE { key=>k, value=>v, count=>1, left=>EMPTY, right=>EMPTY };
node_count (k, v, EMPTY, r as TREE_NODE n) => TREE_NODE { key=>k, value=>v, count=>1+n.count, left=>EMPTY, right=>r };
node_count (k, v, l as TREE_NODE n, EMPTY) => TREE_NODE { key=>k, value=>v, count=>1+n.count, left=>l, right=>EMPTY };
node_count (k, v, l as TREE_NODE n, r as TREE_NODE n')
=>
TREE_NODE { key=>k, value=>v, count=>1+n.count+n'.count, left=>l, right=>r };
end;
fun single_l (a, av, x, TREE_NODE { key=>b, value=>bv, left=>y, right=>z, ... } )
=>
node_count (b, bv, node_count (a, av, x, y), z);
single_l _ => raise exception MATCH;
end;
fun single_r (b, bv, TREE_NODE { key=>a, value=>av, left=>x, right=>y, ... }, z)
=>
node_count (a, av, x, node_count (b, bv, y, z));
single_r _ => raise exception MATCH;
end;
fun double_l (a, av, w, TREE_NODE { key=>c, value=>cv, left=>TREE_NODE { key=>b, value=>bv, left=>x, right=>y, ... }, right=>z, ... } )
=>
node_count (b, bv, node_count (a, av, w, x), node_count (c, cv, y, z));
double_l _ => raise exception MATCH;
end;
fun double_r (c, cv, TREE_NODE { key=>a, value=>av, left=>w, right=>TREE_NODE { key=>b, value=>bv, left=>x, right=>y, ... }, ... }, z)
=>
node_count (b, bv, node_count (a, av, w, x), node_count (c, cv, y, z));
double_r _ => raise exception MATCH;
end;
fun rebalance (k, v, EMPTY, EMPTY)
=>
TREE_NODE { key=>k, value=>v, count=>1, left=>EMPTY, right=>EMPTY };
rebalance (k, v, EMPTY, r as TREE_NODE { right=>EMPTY, left=>EMPTY, ... } )
=>
TREE_NODE { key=>k, value=>v, count=>2, left=>EMPTY, right=>r };
rebalance (k, v, l as TREE_NODE { right=>EMPTY, left=>EMPTY, ... }, EMPTY)
=>
TREE_NODE { key=>k, value=>v, count=>2, left=>l, right=>EMPTY };
rebalance (p as (_, _, EMPTY, TREE_NODE { left=>TREE_NODE _, right=>EMPTY, ... } ))
=>
double_l p;
rebalance (p as (_, _, TREE_NODE { left=>EMPTY, right=>TREE_NODE _, ... }, EMPTY))
=>
double_r p;
# these cases almost never happen with small weight
rebalance (p as (_, _, EMPTY, TREE_NODE { left=>TREE_NODE { count=>ln, ... }, right=>TREE_NODE { count=>rn, ... }, ... } ))
=>
if (ln < rn ) single_l p; else double_l p;fi;
rebalance (p as (_, _, TREE_NODE { left=>TREE_NODE { count=>ln, ... }, right=>TREE_NODE { count=>rn, ... }, ... }, EMPTY))
=>
if (ln > rn ) single_r p; else double_r p;fi;
rebalance (p as (_, _, EMPTY, TREE_NODE { left=>EMPTY, ... } ))
=>
single_l p;
rebalance (p as (_, _, TREE_NODE { right=>EMPTY, ... }, EMPTY))
=>
single_r p;
rebalance (p as (k, v, l as TREE_NODE { count=>ln, left=>ll, right=>lr, ... },
r as TREE_NODE { count=>rn, left=>rl, right=>rr, ... } ))
=>
if (rn >= wt ln ) # right is too big
rln = vals_count rl;
rrn = vals_count rr;
if (rln < rrn ) single_l p; else double_l p;fi;
elif (ln >= wt rn ) # left is too big
lln = vals_count ll;
lrn = vals_count lr;
if (lrn < lln ) single_r p; else double_r p;fi;
else TREE_NODE { key=>k, value=>v, count=>ln+rn+1, left=>l, right=>r };
fi;
end;
stipulate
fun min (TREE_NODE { left=>EMPTY, key, value, ... } ) => (key, value);
min (TREE_NODE { left, ... } ) => min left;
min _ => raise exception MATCH;
end;
fun delmin (TREE_NODE { left=>EMPTY, right, ... } ) => right;
delmin (TREE_NODE { key, value, left, right, ... } ) => rebalance(key, value, delmin left, right);
delmin _ => raise exception MATCH;
end;
herein
fun delete' (EMPTY, r) => r;
delete' (l, EMPTY) => l;
delete' (l, r) => { my (mink, minv) = min r;
rebalance(mink, minv, l, delmin r);
};
end;
end;
herein
fun make_dictionary ()
=
EMPTY;
fun singleton (x, v)
=
TREE_NODE { key=>x, value=>v, count=>1, left=>EMPTY, right=>EMPTY };
fun set (EMPTY, x, v)
=>
TREE_NODE { key=>x, value=>v, count=>1, left=>EMPTY, right=>EMPTY };
set (TREE_NODE (my_set as { key, left, right, value, ... } ), x, v)
=>
case (k::compare (key, x))
#
GREATER => rebalance(key, value, set (left, x, v), right);
LESS => rebalance(key, value, left, set (right, x, v));
_ => TREE_NODE { key=>x, value=>v, left, right, count=> my_set.count };
esac;
end;
fun m $ (x, v)
=
set (m, x, v);
fun set' ((k, x), m)
=
set (m, k, x);
fun contains_key (set, x)
=
mem set
where
fun mem (TREE_NODE (n as { key, left, right, ... } ))
=>
case (k::compare (x, key))
#
GREATER => mem right;
EQUAL => TRUE;
LESS => mem left;
esac;
mem EMPTY => FALSE;
end;
end;
fun preceding_key (set, x)
=
mem (set, NULL)
where
fun maxkey (EMPTY, result)
=>
result;
maxkey (TREE_NODE { key, left, right, ... }, result)
=>
maxkey (right, THE key);
end;
fun mem (TREE_NODE (n as { key, left, right, ... } ), result)
=>
case (k::compare (x, key))
#
GREATER => mem (right, THE key);
EQUAL => maxkey(left, result);
LESS => mem (left, result);
esac;
mem (EMPTY, result) => result;
end;
end;
fun following_key (set, x)
=
mem (set, NULL)
where
fun minkey (EMPTY, result)
=>
result;
minkey (TREE_NODE { key, left, right, ... }, result)
=>
minkey (left, THE key);
end;
fun mem (TREE_NODE (n as { key, left, right, ... } ), result)
=>
case (k::compare (x, key))
#
GREATER => mem (right, result);
EQUAL => result;
LESS => mem (left, THE key);
esac;
mem (EMPTY, result) => result;
end;
end;
# Search on a key, return (THE value) if found,
# else return NULL.
#
fun get (set, x)
=
mem set
where
fun mem (TREE_NODE (n as { key, left, right, ... } ))
=>
case (k::compare (x, key))
#
GREATER => mem right;
EQUAL => THE n.value;
LESS => mem left;
esac;
mem EMPTY => NULL;
end;
end;
# Search on a key, return value if found,
# else raise lib_base::NOT_FOUND
#
fun get_or_raise_exception_not_found (set, x)
=
mem set
where
fun mem (TREE_NODE (n as { key, left, right, ... } ))
=>
case (k::compare (x, key))
#
GREATER => mem right;
EQUAL => n.value;
LESS => mem left;
esac;
mem EMPTY => raise exception lib_base::NOT_FOUND;
end;
end;
stipulate
fun drop'' (EMPTY, x)
=>
raise exception lib_base::NOT_FOUND;
drop'' (set as TREE_NODE { key, left, right, value, ... }, x)
=>
case (k::compare (key, x))
#
GREATER => { (drop'' (left, x)) -> (left', v);
#
(rebalance (key, value, left', right), v);
};
LESS => { (drop'' (right, x)) -> (right', v);
#
(rebalance (key, value, left, right'), v);
};
_ => (delete'(left, right), value);
esac;
end;
herein
fun drop (old_map, key_to_drop) # Return new_map, or old_map if key_to_drop was not found.
=
#1 (drop'' (old_map, key_to_drop))
except
lib_base::NOT_FOUND = old_map;
fun get_and_drop (old_map, key_to_drop) # Return (new_map, THE value) or (old_map, NULL) if key_to_drop was not found.
=
{ (drop'' (old_map, key_to_drop))
->
(new_map, val);
(new_map, THE val);
}
except
lib_base::NOT_FOUND = (old_map, NULL);
end;
fun vals_list d
=
d2l (d,[])
where
fun d2l (TREE_NODE { key, value, left, right, ... }, l)
=>
d2l (left, value ! (d2l (right, l)));
d2l (EMPTY, l) => l;
end;
end;
fun keyvals_list d
=
d2l (d,[])
where
fun d2l (TREE_NODE { key, value, left, right, ... }, l)
=>
d2l (left, (key, value) ! (d2l (right, l)));
d2l (EMPTY, l)
=>
l;
end;
end;
fun keys_list d
=
d2l (d,[])
where
fun d2l (TREE_NODE { key, left, right, ... }, l)
=>
d2l (left, key ! (d2l (right, l)));
d2l (EMPTY, l)
=>
l;
end;
end;
stipulate
fun next ((t as TREE_NODE { right, ... } ) ! rest)
=>
(t, left (right, rest));
next _
=>
(EMPTY, []);
end
also
fun left (t as TREE_NODE { left=>l, ... }, rest)
=>
left (l, t ! rest);
left (EMPTY, rest)
=>
rest;
end;
herein
fun compare_sequences compare_rng (s1, s2)
=
compare (left (s1, []), left (s2, []))
where
fun compare (t1, t2)
=
case (next t1, next t2)
#
((EMPTY, _), (EMPTY, _)) => EQUAL;
((EMPTY, _), _) => LESS;
(_, (EMPTY, _)) => GREATER;
((TREE_NODE { key=>x1, value=>y1, ... }, r1), (TREE_NODE { key=>x2, value=>y2, ... }, r2))
=>
case (key::compare (x1, x2))
#
EQUAL => case (compare_rng (y1, y2))
#
EQUAL => compare (r1, r2);
order => order;
esac;
order => order;
esac;
esac;
end;
end; # stipulate
fun keyed_apply f d
=
apply' d
where
fun apply' (TREE_NODE { key, value, left, right, ... } )
=>
{ apply' left;
f (key, value);
apply' right;
};
apply' EMPTY
=>
();
end;
end;
fun apply f d
=
apply' d
where
fun apply' (TREE_NODE { value, left, right, ... } )
=>
{ apply' left;
f value;
apply' right;
};
apply' EMPTY
=>
();
end;
end;
fun keyed_map f d
=
map' d
where
fun map' (TREE_NODE { key, value, left, right, count } )
=>
{ left' = map' left;
value' = f (key, value);
right' = map' right;
TREE_NODE { count, key, value=>value', left => left', right => right'};
};
map' EMPTY
=>
EMPTY;
end;
end;
fun map f d
=
keyed_map
(\\ (_, x) = f x)
d;
fun keyed_fold_forward f init d
=
fold (d, init)
where
fun fold (TREE_NODE { key, value, left, right, ... }, v)
=>
fold (right, f (key, value, fold (left, v)));
fold (EMPTY, v)
=>
v;
end;
end;
fun fold_forward f init d
=
keyed_fold_forward
(\\ (_, v, accum) = f (v, accum))
init
d;
fun keyed_fold_backward f init d
=
fold (d, init)
where
fun fold (TREE_NODE { key, value, left, right, ... }, v)
=>
fold (left, f (key, value, fold (right, v)));
fold (EMPTY, v)
=>
v;
end;
end;
fun fold_backward f init d
=
keyed_fold_backward
(\\ (_, v, accum) = f (v, accum))
init
d;
## To be implemented ## XXX BUGGO FIXME
# my filter: (X -> Bool) -> Map(X) -> Map(X)
# my keyed_filter: (key::Key * X -> Bool) -> Map(X) -> Map(X)
end; # stipulate
fun difference_with (m1, m2)
=
{ keys_to_remove = keys_list m2;
#
remove (m1, keys_to_remove)
where
fun remove (m1, [])
=>
m1;
remove (m1, key ! rest)
=>
remove (drop (m1, key), rest);
end;
end;
};
fun from_list (pairs: List((key::Key, X)))
=
{ tree = empty;
#
add (tree, pairs)
where
fun add (tree, [])
=>
tree;
add (tree, (key,val) ! rest)
=>
add (set (tree, key, val), rest);
end;
end;
};
# The following are generic implementations
# of the union_with, intersect_with, and
# merge_with operations. These should be
# specialized for the internal
# representations at some point.
fun union_with f (m1, m2)
=
if (vals_count m1 > vals_count m2) keyed_fold_forward (ins (\\ (a, b) = f (b, a))) m1 m2;
else keyed_fold_forward (ins f) m2 m1;
fi
where
fun ins f (key, x, m)
=
case (get (m, key))
#
THE x' => set (m, key, f (x, x'));
NULL => set (m, key, x);
esac;
end;
fun keyed_union_with f (m1, m2)
=
if (vals_count m1 > vals_count m2) keyed_fold_forward (ins (\\ (k, a, b) = f (k, b, a))) m1 m2;
else keyed_fold_forward (ins f) m2 m1;
fi
where
fun ins f (key, x, m)
=
case (get (m, key))
#
THE x' => set (m, key, f (key, x, x'));
NULL => set (m, key, x);
esac;
end;
fun intersect_with f (m1, m2)
=
if (vals_count m1 <= vals_count m2) intersect (\\ (a, b) = f (b, a)) (m2, m1);
else intersect f (m1, m2);
fi
where
# Iterate over the elements of m1,
# checking for membership in m2:
#
fun intersect f (m1, m2)
=
keyed_fold_forward ins empty m1
where
fun ins (key, x, m)
=
case (get (m2, key))
#
NULL => m;
THE x' => set (m, key, f (x, x'));
esac;
end;
end;
fun keyed_intersect_with f (m1, m2)
=
if (vals_count m1 <= vals_count m2) intersect (\\ (k, a, b) = f (k, b, a)) (m2, m1);
else intersect f (m1, m2);
fi
where
# Iterate over the elements of m1,
# checking for membership in m2:
#
fun intersect f (m1, m2)
=
keyed_fold_forward ins empty m1
where
fun ins (key, x, m)
=
case (get (m2, key))
#
NULL => m;
THE x' => set (m, key, f (key, x, x'));
esac;
end;
end;
fun merge_with f (m1, m2)
=
merge (keyvals_list m1, keyvals_list m2, empty)
where
fun merge ([], [], m) => m;
merge ((k1, x1) ! r1, [], m) => mergef (k1, THE x1, NULL, r1, [], m);
merge ([], (k2, x2) ! r2, m) => mergef (k2, NULL, THE x2, [], r2, m);
merge (m1 as ((k1, x1) ! r1), m2 as ((k2, x2) ! r2), m)
=>
case (key::compare (k1, k2))
#
LESS => mergef (k1, THE x1, NULL, r1, m2, m);
EQUAL => mergef (k1, THE x1, THE x2, r1, r2, m);
GREATER => mergef (k2, NULL, THE x2, m1, r2, m);
esac;
end
also
fun mergef (k, x1, x2, r1, r2, m)
=
case (f (x1, x2))
#
THE y => merge (r1, r2, set (m, k, y));
NULL => merge (r1, r2, m);
esac;
end;
fun keyed_merge_with f (m1, m2)
=
merge (keyvals_list m1, keyvals_list m2, empty)
where
fun merge ([], [], m) => m;
merge ((k1, x1) ! r1, [], m) => mergef (k1, THE x1, NULL, r1, [], m);
merge ([], (k2, x2) ! r2, m) => mergef (k2, NULL, THE x2, [], r2, m);
merge (m1 as ((k1, x1) ! r1), m2 as ((k2, x2) ! r2), m)
=>
case (key::compare (k1, k2))
#
LESS => mergef (k1, THE x1, NULL, r1, m2, m);
EQUAL => mergef (k1, THE x1, THE x2, r1, r2, m);
GREATER => mergef (k2, NULL, THE x2, m1, r2, m);
esac;
end
also
fun mergef (k, x1, x2, r1, r2, m)
=
case (f (k, x1, x2))
#
NULL => merge (r1, r2, m);
THE y => merge (r1, r2, set (m, k, y));
esac;
end;
# This is a generic implementation of filter.
# It should be specialized to the data-package at some point.
fun filter pred_g m
=
keyed_fold_forward f empty m
where
fun f (key, item, m)
=
if (pred_g item) set (m, key, item);
else m;
fi;
end;
fun keyed_filter pred_g m
=
keyed_fold_forward f empty m
where
fun f (key, item, m)
=
if (pred_g (key, item)) set (m, key, item);
else m;
fi;
end;
# This is a generic implementation of map'.
# It should be specialized to the data-package at some point.
fun map' f m
=
keyed_fold_forward g empty m
where
fun g (key, item, m)
=
case (f item)
#
THE item' => set (m, key, item');
NULL => m;
esac;
end;
fun keyed_map' f m
=
keyed_fold_forward g empty m
where
fun g (key, item, m)
=
case (f (key, item))
#
THE item' => set (m, key, item');
NULL => m;
esac;
end;
}; # generic package binary_map_g
## COPYRIGHT (c) 1993 by AT&T Bell Laboratories. See SMLNJ-COPYRIGHT file for details.
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.