PreviousUpNext

15.4.907  src/lib/src/interval-set-g.pkg

## 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.


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext