## int-binary-map.pkg
#
# Normally
# src/lib/src/int-red-black-map.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.
#
# Altered to work as a general intmap - Emden Gansner
package int_binary_map : Map # Map is from src/lib/src/map.apiwhere
key::Key == int::Int
=
package {
package key {
Key = int::Int;
compare = int::compare;
};
# weight = 3
# fun wt i = weight * i
fun wt (i: Int)
=
i + i + i;
Map(X) = EMPTY
| TREE_NODE {
key: Int,
value: X,
count: Int,
left: Map(X),
right: Map(X)
};
fun debug_print (map, print_key, print_val) = 0; # Placeholder
fun all_invariants_hold map = TRUE; # Placeholder
fun is_empty EMPTY => TRUE;
is_empty _ => FALSE;
end;
fun vals_count (TREE_NODE { count, ... } )
=>
count;
vals_count EMPTY
=>
0;
end;
# Return the first item in the map.
# Return NULL if it is empty.
#
fun first_val_else_null (TREE_NODE { value, left=>EMPTY, ... } )
=>
THE value;
first_val_else_null (TREE_NODE { left, ... } )
=>
first_val_else_null left;
first_val_else_null EMPTY
=>
NULL;
end;
# Return the first item in the map
# and its key. Return NULL if it is empty:
#
fun 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;
first_keyval_else_null EMPTY
=>
NULL;
end;
# Return the last item in the map.
# Return NULL if it is empty.
#
fun last_val_else_null (TREE_NODE { value, right=>EMPTY, ... } )
=>
THE value;
last_val_else_null (TREE_NODE { right, ... } )
=>
last_val_else_null right;
last_val_else_null EMPTY
=>
NULL;
end;
# Return the last item in the map
# and its key. Return NULL if it is empty:
#
fun 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;
last_keyval_else_null EMPTY
=>
NULL;
end;
stipulate
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 n ) => TREE_NODE { key=>k, value=>v, count=>1+n.count, left=>EMPTY, right=>r };
rebalance (k, v, l as TREE_NODE n, EMPTY ) => TREE_NODE { key=>k, value=>v, count=>1+n.count, left=>l, right=>EMPTY };
rebalance (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, ... } )
=>
rebalance (b, bv, rebalance (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)
=>
rebalance (a, av, x, rebalance (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, ... } )
=>
rebalance (b, bv, rebalance (a, av, w, x), rebalance (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)
=>
rebalance (b, bv, rebalance (a, av, w, x), rebalance (c, cv, y, z));
double_r _
=>
raise exception MATCH;
end;
fun tree_node' (k, v, EMPTY, EMPTY)
=>
TREE_NODE { key=>k, value=>v, count=>1, left=>EMPTY, right=>EMPTY };
tree_node' (k, v, EMPTY, r as TREE_NODE { right=>EMPTY, left=>EMPTY, ... } )
=>
TREE_NODE { key=>k, value=>v, count=>2, left=>EMPTY, right=>r };
tree_node' (k, v, l as TREE_NODE { right=>EMPTY, left=>EMPTY, ... }, EMPTY)
=>
TREE_NODE { key=>k, value=>v, count=>2, left=>l, right=>EMPTY };
tree_node' (p as (_, _, EMPTY, TREE_NODE { left=>TREE_NODE _, right=>EMPTY, ... } ))
=>
double_l p;
tree_node' (p as (_, _, TREE_NODE { left=>EMPTY, right=>TREE_NODE _, ... }, EMPTY))
=>
double_r p;
# These cases almost never
# happen with small weight:
tree_node' (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;
tree_node' (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;
tree_node' (p as (_, _, EMPTY, TREE_NODE { left=>EMPTY, ... } )) => single_l p;
tree_node' (p as (_, _, TREE_NODE { right=>EMPTY, ... }, EMPTY)) => single_r p;
tree_node' (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, ... } )
=>
tree_node'(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;
tree_node'(mink, minv, l, delmin r);
};
end;
end;
herein
empty = 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)
=>
if (key > x) tree_node'(key, value, set (left, x, v), right);
elif (key < x) tree_node'(key, value, left, set (right, x, v));
else TREE_NODE { key=>x, value=>v, left, right, count=> my_set.count };
fi;
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 EMPTY
=>
FALSE;
mem (TREE_NODE (n as { key, left, right, ... } ))
=>
if (x > key) mem right;
elif (x < key) mem left;
else TRUE;
fi;
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 (EMPTY, result)
=>
result;
mem (TREE_NODE (n as { key, left, right, ... } ), result)
=>
if (x > key) mem (right, THE key);
elif (x < key) mem (left, result );
else maxkey(left, result );
fi;
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 (EMPTY, result)
=>
result;
mem (TREE_NODE (n as { key, left, right, ... } ), result)
=>
if (x > key) mem (right, result );
elif (x < key) mem (left, THE key);
else minkey(right, result );
fi;
end;
end;
# Search on a key, return value if found,
# else raise lib_base::NOT_FOUND
#
fun get (set, x)
=
{ fun mem EMPTY => NULL;
#
mem (TREE_NODE (n as { key, left, right, ... } ))
=>
if (x > key) mem right;
elif (x < key) mem left;
else THE n.value;
fi;
end;
mem set;
};
# Search on a key, return value if found,
# else raise lib_base::NOT_FOUND
#
fun get_or_raise_exception_not_found (map, x)
=
mem map
where
fun mem EMPTY => raise exception lib_base::NOT_FOUND;
#
mem (TREE_NODE (n as { key, left, right, ... } ))
=>
if (x > key) mem right;
elif (x < key) mem left;
else n.value;
fi;
end;
end;
stipulate
fun drop'' (EMPTY, x)
=>
raise exception lib_base::NOT_FOUND;
drop'' (set as TREE_NODE { key, left, right, value, ... }, x)
=>
if (key > x)
#
(drop'' (left, x)) -> (left', v);
(tree_node'(key, value, left', right), v);
elif (key < x)
(drop'' (right, x)) -> (right', v);
(tree_node'(key, value, left, right'), v);
else
(delete' (left, right), value);
fi;
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 (EMPTY, l)
=>
l;
d2l (TREE_NODE { key, value, left, right, ... }, l)
=>
d2l (left, value ! (d2l (right, l)));
end;
end;
fun keyvals_list d
=
d2l (d,[])
where
fun d2l (EMPTY, l)
=>
l;
d2l (TREE_NODE { key, value, left, right, ... }, l)
=>
d2l (left, (key, value) ! (d2l (right, 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 (EMPTY, rest)
=>
rest;
left (t as TREE_NODE { left=>l, ... }, rest)
=>
left (l, t ! 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
=
appf d
where
fun appf (TREE_NODE { key, value, left, right, ... } )
=>
{ appf left;
f (key, value);
appf right;
};
appf EMPTY
=>
();
end;
end;
fun apply f d
=
keyed_apply
(\\ (_, v) = f v)
d;
fun keyed_map f d
=
mapf d
where
fun mapf (TREE_NODE { key, value, left, right, count } )
=>
{ left' = mapf left;
value' = f (key, value);
right' = mapf right;
TREE_NODE { count, key, value=>value', left => left', right => right'};
};
mapf 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;
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 operetions. 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))
NULL => set (m, key, x);
THE x' => set (m, key, f (x, 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))
NULL => set (m, key, x);
THE x' => set (m, key, f (key, x, x'));
esac;
end;
fun intersect_with f (m1, m2)
=
if (vals_count m1 > vals_count m2) intersect f (m1, m2);
else intersect (\\ (a, b) = f (b, a)) (m2, m1);
fi
where
# Iterate over the elements of m1,
# checking for membership in m2
fun intersect f (m1, m2)
=
{ fun ins (key, x, m)
=
case (get (m2, key))
NULL => m;
THE x' => set (m, key, f (x, x'));
esac;
keyed_fold_forward ins empty m1;
};
end;
fun keyed_intersect_with f (m1, m2)
=
if (vals_count m1 > vals_count m2) intersect f (m1, m2);
else intersect (\\ (k, a, b) = f (k, b, a)) (m2, m1);
fi
where
# Iterate over the elements of m1,
# checking for membership in m2:
#
fun intersect f (m1, m2)
=
{ fun ins (key, x, m)
=
case (get (m2, key))
NULL => m;
THE x' => set (m, key, f (key, x, x'));
esac;
keyed_fold_forward ins empty m1;
};
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)
=>
if (k1 < k2)
mergef (k1, THE x1, NULL, r1, m2, m);
else
if (k1 == k2) mergef (k1, THE x1, THE x2, r1, r2, m);
else mergef (k2, NULL, THE x2, m1, r2, m); fi;
fi;
end
also
fun mergef (k, x1, x2, r1, r2, m)
=
case (f (x1, x2))
NULL => merge (r1, r2, m);
THE y => merge (r1, r2, set (m, k, y));
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)
=>
if (k1 < k2) mergef (k1, THE x1, NULL, r1, m2, m); else
if (k1 == k2) mergef (k1, THE x1, THE x2, r1, r2, m); else
mergef (k2, NULL, THE x2, m1, r2, m); fi;
fi;
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. XXX BUGGO FIXME
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)
NULL
=>
m;
THE item'
=>
set (m, key, item');
esac;
end;
fun keyed_map' f m
=
keyed_fold_forward g empty m
where
fun g (key, item, m)
=
case (f (key, item))
NULL => m;
THE item' => set (m, key, item');
esac;
end;
};
## 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.