Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] View of /smlnj-lib/trunk/Util/interval-set-fn.sml
ViewVC logotype

View of /smlnj-lib/trunk/Util/interval-set-fn.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 2144 - (download) (annotate)
Thu Nov 2 16:23:11 2006 UTC (12 years, 11 months ago) by blume
File size: 9733 byte(s)
moved smlnj-lib to toplevel
(* interfun-set-fn.sml
 *
 * COPYRIGHT (c) 2005 John Reppy (http://www.cs.uchicago.edu/~jhr)
 * All rights reserved.
 *
 * 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).
 *)

functor IntervalSetFn (D : INTERVAL_DOMAIN) : INTERVAL_SET =
  struct

    structure D = D

    type item = D.point
    type interval = (D.point * D.point)

    fun min (a, b) = (case D.compare(a, b)
	   of LESS => a
	    | _ => b
	  (* end case *))

  (* the set is represented by an ordered list of disjoint, non-adjacent intervals *)
    datatype set = SET of interval list

    val empty = SET[]
    val universe = SET[(D.minPt, D.maxPt)]

    fun isEmpty (SET []) = true
      | isEmpty _ = false

    fun isUniverse (SET[(a, b)]) =
	  (D.compare(a, D.minPt) = EQUAL) andalso (D.compare(b, D.maxPt) = EQUAL)
      | isUniverse _ = false

    fun singleton x = SET[(x, x)]

    fun interval (a, b) = (case D.compare(a, b)
	   of GREATER => raise Domain
	    | _ => SET[(a, b)]
	  (* end case *))

    fun addInt (SET l, (a, b)) = let
	  fun ins (a, b, []) = [(a, b)]
	    | ins (a, b, (x, y)::r) = (case D.compare(b, x)
		 of LESS => if (D.isSucc(b, x))
		      then (a, y)::r
		      else (a, b)::(x, y)::r
		  | EQUAL => (a, y)::r
		  | GREATER => (case D.compare(a, y)
		       of GREATER => if (D.isSucc(y, a))
			    then (x, b) :: r
			    else (x, y) :: ins(a, b, r)
			| EQUAL => ins(x, b, r)
			| LESS => (case D.compare(b, y)
			     of GREATER => ins (min(a, x), b, r)
			      | _ => ins (min(a, x), y, r)
			    (* end case *))
		      (* end case *))
		(* end case *))
	  in
	    case D.compare(a, b)
	     of GREATER => raise Domain
	      | _ => SET(ins (a, b, l))
	    (* end case *)
	  end
    fun addInt' (x, m) = addInt (m, x)

    fun add (SET l, a) = let
	  fun ins (a, []) = [(a, a)]
	    | ins (a, (x, y)::r) = (case D.compare(a, x)
		 of LESS => if (D.isSucc(a, x))
		      then (a, y)::r
		      else (a, a)::(x, y)::r
		  | EQUAL => (a, y)::r
		  | GREATER => (case D.compare(a, y)
		       of GREATER => if (D.isSucc(y, a))
			    then (x, a) :: r
			    else (x, y) :: ins(a, r)
			| _ => (x, y)::r
		      (* end case *))
		(* end case *))
	  in
	    SET(ins (a, l))
	  end
    fun add' (x, m) = add (m, x)

  (* is a point in any of the intervals in the set *)
    fun member (SET l, pt) = let
	  fun look [] = false
	    | look ((a, b) :: r) = (case D.compare(a, pt)
		 of LESS => (case D.compare(pt, b)
			 of GREATER => look r
			  | _ => true
		      (* end case *))
		  | EQUAL => true
		  | GREATER => false
		(* end case *))
	  in
	    look l
	  end

    fun complement (SET[]) = universe
      | complement (SET((a, b)::r)) = let
	  fun comp (start, (a, b)::r, l) =
		comp(D.succ b, r, (start, D.pred a)::l)
	    | comp (start, [], l) = (case D.compare(start, D.maxPt)
		 of LESS => SET(List.rev((start, D.maxPt)::l))
		  | _ => SET(List.rev l)
		(* end case *))
	  in
	    case D.compare(D.minPt, a)
	     of LESS => comp(D.succ b, r, [(D.minPt, D.pred a)])
	      | _ => comp(D.succ b, r, [])
	    (* end case *)
	  end

    fun union (SET l1, SET l2) = let
	  fun join ([], l2) = l2
	    | join (l1, []) = l1
	    | join ((a1, b1)::r1, (a2, b2)::r2) = (case D.compare(a1, a2)
		 of LESS => (case D.compare(b1, b2)
		       of LESS => if D.isSucc(b1, a2)
			    then join(r1, (a1, b2)::r2)
			    else (a1, b1) :: join(r1, (a2, b2)::r2)
			| EQUAL => (a1, b1) :: join(r1, r2)
			| GREATER => join ((a1, b1)::r1, r2)
		      (* end case *))
		  | EQUAL => (case D.compare(b1, b2)
		       of LESS => join(r1, (a2, b2)::r2)
			| EQUAL => (a1, b1) :: join(r1, r2)
			| GREATER => join ((a1, b1)::r1, r2)
		      (* end case *))
		  | GREATER => (case D.compare(a1, b2)
		       of LESS => (case D.compare(b1, b2)
			     of LESS => join (r1, (a2, b2)::r2)
			      | EQUAL => (a2, b2) :: join(r1, r2)
			      | GREATER => join ((a2, b1)::r1, r2)
			    (* end case *))
			| EQUAL => (* a2 < a1 = b2 <= b1 *)
			    join ((a2, b1)::r1, r2)
			| GREATER => if D.isSucc(b2, a1)
			    then join ((a2, b1)::r1, r2)
			    else (a2, b2) :: join ((a1, b1)::r1, r2)
		      (* end case *))
		(* end case *))
	  in
	    SET(join(l1, l2))
	  end

    fun intersect (SET l1, SET l2) = let
	(* cons a possibly empty interval onto the front of l *)
	  fun cons (a, b, l) = (case D.compare(a, b)
		 of GREATER => l
		  | _ => (a, b) :: l
		(* end case *))
	  fun meet ([], _) = []
	    | meet (_, []) = []
	    | meet ((a1, b1)::r1, (a2, b2)::r2) = (case D.compare(a1, a2)
		 of LESS => (case D.compare(b1, a2)
		       of LESS => (* a1 <= b1 < a2 <= b2 *)
			    meet (r1, (a2, b2)::r2)
			| EQUAL => (* a1 <= b1 = a2 <= b2 *)
			    (b1, b1) :: meet (r1, cons(D.succ b1, b2, r2))
			| GREATER => (case D.compare (b1, b2)
			     of LESS => (* a1 < a2 < b1 < b2 *)
				  (a2, b1) :: meet (r1, cons(D.succ b1, b2, r2))
			      | EQUAL => (* a1 < a2 < b1 = b2 *)
				  (a2, b1) :: meet (r1, r2)
			      | GREATER => (* a1 < a2 < b1 & b2 < b1  *)
				  (a2, b2) :: meet (cons(D.succ b2, b1, r1), r2)
			    (* end case *))
		      (* end case *))
		  | EQUAL => (case D.compare(b1, b2)
		       of LESS => (a1, b1) :: meet (r1, cons(D.succ b1, b2, r2))
			| EQUAL => (a1, b1) :: meet (r1, r2)
			| GREATER => (a1, b2) :: meet ((D.succ b2, b1)::r1, r2)
		      (* end case *))
		  | GREATER => (case D.compare(b2, a1)
		       of LESS => (* a2 <= b2 < a1 <= b1 *)
			    meet ((a1, b1)::r1, r2)
			| EQUAL => (* a2 < b2 = a1 <= b1 *)
			    (b2, b2) :: meet (cons(D.succ b2, b1, r1), r2)
			| GREATER => (case D.compare(b1, b2)
			     of LESS => (* a2 < a1 <= b1 < b2 *)
				  (a1, b1) :: meet (r1, cons(D.succ b1, b2, r2))
			      | EQUAL => (* a2 < a1 <= b1 = b2 *)
				  (a1, b1) :: meet (r1, r2)
			      | GREATER => (* a2 < a1 < b2 < b1 *)
				  (a1, b2) :: meet (cons(D.succ b2, b1, r1), r2)
			    (* end case *))
		      (* end case *))
		(* end case *))
	  in
	    SET(meet(l1, l2))
	  end

  (* FIXME: replace the following with a direct implementation *)
    fun difference (s1, s2) = intersect(s1, complement s2)

  (***** iterators on elements *****)
    local
      fun next [] = NONE
	| next ((a, b)::r) =
	    if D.compare(a, b) = EQUAL
	      then SOME(a, r)
	      else SOME(a, (D.succ a, b)::r)
    in
    fun items (SET l) = let
	  fun list (l, items) = (case next l
		 of NONE => List.rev items
		  | SOME(x, r) => list(r, x::items)
		(* end case *))
	  in
	    list (l, [])
	  end
    fun app f (SET l) = let
	  fun appf l = (case next l
		 of NONE => ()
		  | SOME(x, r) => (f x; appf r)
		(* end case *))
	  in
	    appf l
	  end
    fun foldl f = let
	  fun foldf (l, acc) = (case next l
		 of NONE => acc
		  | SOME(x, r) => foldf(r, f(x, acc))
		(* end case *))
	  in
	    fn init => fn (SET l) => foldf(l, init)
	  end
    fun foldr f init (SET l) = let
	  fun foldf l = (case next l
		 of NONE => init
		  | SOME(x, r) => f (x, foldf r)
		(* end case *))
	  in
	    foldf l
	  end
    fun filter pred (SET l) = let
	(* given an interval [a, b], filter its elements and add the subintervals that pass
	 * the predicate to the list l.
	 *)
	  fun filterInt ((a, b), l) = let
		fun lp (start, item, last, l) = let
		      val next = D.succ item
		      in
			if pred next
			  then if (D.compare(next, last) = EQUAL)
			    then (start, next)::l
			    else lp(start, next, last, l)
			  else scan(D.succ next, last, (start, item)::l)
		      end
		and scan (next, last, l) = if pred next
		      then lp (next, next, last, l)
		      else if (D.compare(next, last) = EQUAL)
			then l
			else scan(D.succ next, last, l)
		in
		  scan (a, b, l)
		end
	(* filter the intervals *)
	  fun filter' ([], l) = SET(List.rev l)
	    | filter' (i::r, l) = filter' (r, filterInt (i, l))
	  in
	    filter' (l, [])
	  end
    fun all pred (SET l) = let
	  fun all' l = (case next l
		 of NONE => true
		  | SOME(x, r) => (pred x andalso all' r)
		(* end case *))
	  in
	    all' l
	  end
    fun exists pred (SET l) = let
	  fun exists' l = (case next l
		 of NONE => false
		  | SOME(x, r) => (pred x orelse exists' r)
		(* end case *))
	  in
	    exists' l
	  end
    end (* local *)

  (***** Iterators on interfuns *****)
    fun intervals (SET l) = l

    fun appInt f (SET l) = List.app f l

    fun foldlInt f init (SET l) = List.foldl f init l

    fun foldrInt f init (SET l) = List.foldl f init l

    fun filterInt pred (SET l) = let
	  fun f' ([], l) = SET(List.rev l)
	    | f' (i::r, l) = if pred i
		then f'(r, i::l)
		else f'(r, l)
	  in
	    f' (l, [])
	  end

    fun existsInt pred (SET l) = List.exists pred l

    fun allInt pred (SET l) = List.all pred l

    fun compare (SET l1, SET l2) = let
	  fun comp ([], []) = EQUAL
	    | comp ((a1, b1)::r1, (a2, b2)::r2) = (case D.compare(a1, a2)
		 of EQUAL => (case D.compare(b1, b2)
		       of EQUAL => comp (r1, r2)
			| someOrder => someOrder
		      (* end case *))
		  | someOrder => someOrder
		(* end case *))
	    | comp ([], _) = LESS
	    | comp (_, []) = GREATER
	  in
	    comp(l1, l2)
	  end

    fun isSubset (SET l1, SET l2) = let
	(* is the interval [a, b] covered by [x, y]? *)
	  fun isCovered (a, b, x, y) = (case D.compare(a, x)
		 of LESS => false
		  | _ => (case D.compare(y, b)
		       of LESS => false
			| _ => true
		      (* end case *))
		(* end case *))
	  fun test ([], _) = true
	    | test (_, []) = false
	    | test ((a1, b1)::r1, (a2, b2)::r2) =
		if isCovered (a1, b1, a2, b2)
		  then test (r1, (a2, b2)::r2)
		  else (case D.compare(b2, a1)
		     of LESS => test ((a1, b1)::r1, r2)
		      | _ => false
		    (* end case *))
	  in
	    test (l1, l2)
	  end

  end

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0