## interval-set-g.pkg
# Compiled by:
# src/lib/std/standard.lib# An implementation of sets over a discrete ordered domain, where the
# sets are represented by intervals. It is meant for representing
# dense sets (e.g., unicode character classes).
### "No, I'm not interested in developing a powerful brain.
### All I'm after is just a mediocre brain, something like
### the President of the American Telephone and Telegraph Company."
###
### -- Alan Turing
# This generic is invoked in:
#
# src/app/future-lex/src/regular-expression.pkg#
generic package interval_set_g (d: Interval_Domain ) # Interval_Domain is from src/lib/src/interval-domain.api: (weak) Interval_Set # Interval_Set is from src/lib/src/interval-set.api{
package d = d;
Item = d::Point;
Interval = ((d::Point, d::Point));
fun min (a, b)
=
case (d::compare (a, b))
LESS => a;
_ => b;
esac;
# The set is represented by an ordered list
# of disjoint, non-adjacent intervals:
Set = SET List( Interval );
empty = SET [];
universe = SET [ (d::min_pt, d::max_pt) ];
fun is_empty (SET []) => TRUE;
is_empty _ => FALSE;
end;
fun is_universe (SET [ (a, b) ] )
=>
(d::compare (a, d::min_pt) == EQUAL) and
(d::compare (b, d::max_pt) == EQUAL);
is_universe _ => FALSE;
end;
fun singleton x
=
SET [ (x, x) ];
fun interval (a, b)
=
case (d::compare (a, b))
GREATER => raise exception DOMAIN;
_ => SET [ (a, b) ];
esac;
fun add_int (SET l, (a, b))
=
{ fun ins (a, b, [])
=>
[(a, b)];
ins (a, b, (x, y) ! r)
=>
case (d::compare (b, x))
LESS
=>
if (d::is_succ (b, x)) (a, y) ! r;
else (a, b) ! (x, y) ! r;
fi;
EQUAL
=>
(a, y) ! r;
GREATER
=>
case (d::compare (a, y))
GREATER
=>
if (d::is_succ (y, a)) (x, b) ! r;
else (x, y) ! ins (a, b, r);
fi;
EQUAL
=>
ins (x, b, r);
LESS
=>
case (d::compare (b, y))
GREATER => ins (min (a, x), b, r);
_ => ins (min (a, x), y, r);
esac;
esac;
esac;
end;
case (d::compare (a, b))
GREATER => raise exception DOMAIN;
_ => SET (ins (a, b, l));
esac;
};
fun add_int' (x, m)
=
add_int (m, x);
fun add (SET l, a)
=
SET (ins (a, l))
where
fun ins (a, []) => [(a, a)];
ins (a, (x, y) ! r)
=>
case (d::compare (a, x))
LESS
=>
if (d::is_succ (a, x)) (a, y) ! r;
else (a, a) ! (x, y) ! r;
fi;
EQUAL
=>
(a, y) ! r;
GREATER
=>
case (d::compare (a, y))
GREATER
=>
if (d::is_succ (y, a)) (x, a) ! r;
else (x, y) ! ins (a, r);
fi;
_ =>
(x, y) ! r;
esac;
esac;
end;
end;
fun add' (x, m)
=
add (m, x);
# Is a point in any of the intervals in the set?
fun member (SET l, pt)
=
get l
where
fun get []
=>
FALSE;
get ((a, b) ! r)
=>
case (d::compare (a, pt))
EQUAL => TRUE;
GREATER => FALSE;
LESS
=>
case (d::compare (pt, b))
GREATER => get r;
_ => TRUE;
esac;
esac;
end;
end;
fun complement (SET [])
=>
universe;
complement (SET((a, b) ! r))
=>
{ fun comp (start, (a, b) ! r, l)
=>
comp (d::next b, r, (start, d::prior a) ! l);
comp (start, [], l)
=>
case (d::compare (start, d::max_pt))
LESS => SET (list::reverse((start, d::max_pt) ! l));
_ => SET (list::reverse l);
esac;
end;
case (d::compare (d::min_pt, a))
LESS => comp (d::next b, r, [(d::min_pt, d::prior a)]);
_ => comp (d::next b, r, []);
esac;
};
end;
fun union (SET l1, SET l2)
=
SET (join (l1, l2))
where
fun join ([], l2) => l2;
join (l1, []) => l1;
join ((a1, b1) ! r1, (a2, b2) ! r2)
=>
case (d::compare (a1, a2))
LESS
=>
case (d::compare (b1, b2))
LESS
=>
if (d::is_succ (b1, a2)) join (r1, (a1, b2) ! r2);
else (a1, b1) ! join (r1, (a2, b2) ! r2);
fi;
EQUAL
=>
(a1, b1) ! join (r1, r2);
GREATER
=>
join ((a1, b1) ! r1, r2);
esac;
EQUAL
=>
case (d::compare (b1, b2))
LESS => join (r1, (a2, b2) ! r2);
EQUAL => (a1, b1) ! join (r1, r2);
GREATER => join ((a1, b1) ! r1, r2);
esac;
GREATER
=>
case (d::compare (a1, b2))
LESS
=>
case (d::compare (b1, b2))
LESS => join (r1, (a2, b2) ! r2);
EQUAL => (a2, b2) ! join (r1, r2);
GREATER => join ((a2, b1) ! r1, r2);
esac;
EQUAL
=> # A2 < a1 = b2 <= b1
join ((a2, b1) ! r1, r2);
GREATER
=>
if (d::is_succ (b2, a1)) join ((a2, b1) ! r1, r2);
else (a2, b2) ! join ((a1, b1) ! r1, r2);
fi;
esac;
esac;
end;
end;
fun intersect (SET l1, SET l2)
=
SET (meet (l1, l2))
where
# Cons a possibly empty interval onto the front of l
fun cons (a, b, l)
=
case (d::compare (a, b))
GREATER => l;
_ => (a, b) ! l;
esac;
fun meet ([], _) => [];
meet (_, []) => [];
meet ((a1, b1) ! r1, (a2, b2) ! r2)
=>
case (d::compare (a1, a2))
LESS
=>
case (d::compare (b1, a2))
LESS
=> # A1 <= b1 < a2 <= b2
meet (r1, (a2, b2) ! r2);
EQUAL
=> # A1 <= b1 = a2 <= b2
(b1, b1) ! meet (r1, cons (d::next b1, b2, r2));
GREATER
=>
case (d::compare (b1, b2))
LESS
=>
# A1 < a2 < b1 < b2
(a2, b1) ! meet (r1, cons (d::next b1, b2, r2));
EQUAL
=> # A1 < a2 < b1 = b2
(a2, b1) ! meet (r1, r2);
GREATER
=> # A1 < a2 < b1 & b2 < b1
(a2, b2) ! meet (cons (d::next b2, b1, r1), r2);
esac;
esac;
EQUAL
=>
case (d::compare (b1, b2))
LESS => (a1, b1) ! meet (r1, cons (d::next b1, b2, r2));
EQUAL => (a1, b1) ! meet (r1, r2);
GREATER => (a1, b2) ! meet ((d::next b2, b1) ! r1, r2);
esac;
GREATER
=>
case (d::compare (b2, a1))
LESS
=> # A2 <= b2 < a1 <= b1
meet ((a1, b1) ! r1, r2);
EQUAL
=> # A2 < b2 = a1 <= b1
(b2, b2) ! meet (cons (d::next b2, b1, r1), r2);
GREATER
=>
case (d::compare (b1, b2))
LESS
=> # A2 < a1 <= b1 < b2
(a1, b1) ! meet (r1, cons (d::next b1, b2, r2));
EQUAL
=> # A2 < a1 <= b1 = b2
(a1, b1) ! meet (r1, r2);
GREATER
=> # A2 < a1 < b2 < b1
(a1, b2) ! meet (cons (d::next b2, b1, r1), r2);
esac;
esac;
esac;
end; # fun meet
end;
# XXX BUGGO FIXME: replace the following with a direct implementation
fun difference (s1, s2)
=
intersect (s1, complement s2);
# **** iterators on elements ****
stipulate
fun next []
=>
NULL;
next ((a, b) ! r)
=>
if (d::compare (a, b) == EQUAL) THE (a, r);
else THE (a, (d::next a, b) ! r);
fi;
end;
herein
fun items (SET l)
=
list (l, [])
where
fun list (l, items)
=
case (next l)
NULL => list::reverse items;
THE (x, r) => list (r, x ! items);
esac;
end;
fun apply f (SET l)
=
appf l
where
fun appf l
=
case (next l)
NULL => ();
THE (x, r) => { f x; appf r; };
esac;
end;
fun fold_forward f
=
\\ init = \\ (SET l) = foldf (l, init)
where
fun foldf (l, acc)
=
case (next l)
NULL => acc;
THE (x, r) => foldf (r, f (x, acc));
esac;
end;
fun fold_backward f init (SET l)
=
foldf l
where
fun foldf l
=
case (next l)
NULL => init;
THE (x, r) => f (x, foldf r);
esac;
end;
fun filter prior (SET l)
=
filter' (l, [])
where
# Given an interval [a, b],
# filter its elements and add
# the subintervals that pass
# the predicate to the list l.
fun filter_int ((a, b), l)
=
scan (a, b, l)
where
fun lp (start, item, last, l)
=
{ next = d::next item;
if (prior next)
if (d::compare (next, last) == EQUAL) (start, next) ! l;
else lp (start, next, last, l);
fi;
else
scan (d::next next, last, (start, item) ! l);
fi;
}
also
fun scan (next, last, l)
=
if (prior next)
lp (next, next, last, l);
else
if (d::compare (next, last) == EQUAL) l;
else scan (d::next next, last, l);
fi;
fi;
end;
# Filter the intervals:
fun filter' ([], l) => SET (list::reverse l);
filter' (i ! r, l) => filter' (r, filter_int (i, l));
end;
end;
fun all prior (SET l)
=
all' l
where
fun all' l
=
case (next l)
NULL => TRUE;
THE (x, r) => (prior x and all' r);
esac;
end;
fun exists prior (SET l)
=
exists' l
where
fun exists' l
=
case (next l)
NULL => FALSE;
THE (x, r) => (prior x or exists' r);
esac;
end;
end; # stipulate
# **** Iterators on interfuns ****
fun intervals (SET l) = l;
fun apply_int f (SET l) = list::apply f l;
fun foldl_int f init (SET l) = list::fold_forward f init l;
fun foldr_int f init (SET l) = list::fold_forward f init l;
fun filter_int prior (SET l)
=
f' (l, [])
where
fun f' ([], l)
=>
SET (list::reverse l);
f' (i ! r, l)
=>
if (prior i) f'(r, i ! l);
else f'(r, l);
fi;
end;
end;
fun exists_int prior (SET l)
=
list::exists prior l;
fun all_int prior (SET l)
=
list::all prior l;
fun compare (SET l1, SET l2)
=
comp (l1, l2)
where
fun comp ([], [])
=>
EQUAL;
comp ((a1, b1) ! r1, (a2, b2) ! r2)
=>
case (d::compare (a1, a2))
EQUAL
=>
case (d::compare (b1, b2))
EQUAL => comp (r1, r2);
some_order => some_order;
esac;
some_order
=>
some_order;
esac;
comp ([], _) => LESS;
comp (_, []) => GREATER;
end;
end;
fun is_subset (SET l1, SET l2)
=
test (l1, l2)
where
# Is the interval [a, b] covered by [x, y]?
fun is_covered (a, b, x, y)
=
case (d::compare (a, x))
LESS => FALSE;
_ =>
case (d::compare (y, b))
LESS => FALSE;
_ => TRUE;
esac;
esac;
fun test ([], _) => TRUE;
test (_, []) => FALSE;
test ((a1, b1) ! r1, (a2, b2) ! r2)
=>
if (is_covered (a1, b1, a2, b2))
test (r1, (a2, b2) ! r2);
else
case (d::compare (b2, a1))
LESS => test ((a1, b1) ! r1, r2);
_ => FALSE;
esac;
fi;
end;
end;
};
## COPYRIGHT (c) 2005 John Reppy (http://www.cs.uchicago.edu/~jhr)
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.