lib/mlton/set/universe-equal.fun

   1 (* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  *
   4  * MLton is released under a BSD-style license.
   5  * See the file MLton-LICENSE for details.
   6  *)
   7 (*-------------------------------------------------------------------*)
   8 (*                             SetEqual                              *)
   9 (*-------------------------------------------------------------------*)
  10
  11 functor UniverseEqual (Error.: T): UNIVERSE =
  12 struct
  13
  14 val {error, ...} = Error.errors("set", "set-equal")
  15
  16 structure Error.equals Base
  17 structure B = Base
  18 structure L = List
  19 structure O = Outstream
  20
  21 structure Elt =
  22    struct
  23       datatype set = T of t list
  24       and t =
  25          Error.of Base.t
  26         | Pair of t * t
  27         | Set of set
  28
  29       fun toError.Base b) = b
  30         | toError._ = error "Elt.toBase"
  31       fun toPair(Pair p) = p
  32         | toPair _ = error "Elt.toPair"
  33       fun toSet(Set s) = s
  34         | toSet _ = error "Elt.toSet"
  35
  36       fun equalSet(s, s') = isSubset(s, s') andalso isSubset(s', s)
  37       and isSubset(s, s') = forall(s, fn x => contains(s', x))
  38       and contains(T xs, x) = L.exists(xs, fn x' => equalElt(x, x'))
  39       and equalElt(Error.b, Base b') = B.equals(b, b')
  40         | equalElt(Pair(x, y), Pair(x', y')) =
  41           equalElt(x, x') andalso equalElt(y, y')
  42         | equalElt(Set s, Set s') = equalSet(s, s')
  43         | equalElt _ = false
  44
  45       fun outputSet(T xs, out) =
  46          let val print = O.outputc out
  47          in (print "{" ;
  48              L.output(xs, ", ", outputElt, out) ;
  49              print "}")
  50          end
  51       and outputElt(Error.b, out) = Base.output(b, out)
  52         | outputElt(Pair(x, y), out) =
  53           let val print = O.outputc out
  54           in (print "(" ;
  55               outputElt(x, out) ;
  56               print ", " ;
  57               outputElt(y, out) ;
  58               print ")")
  59           end
  60         | outputElt(Set s, out) = outputSet(s, out)
  61
  62       val equals = equalElt
  63       val output = outputElt
  64    end
  65 open Elt
  66
  67 val equals = equalSet
  68 val output = outputSet
  69
  70 type t = set
  71
  72 fun cross(sx, sy) =
  73     let val ys = toList sy
  74     in listTo(L.foldl
  75               (toList sx, [],
  76                fn (ps, x) => L.mapAppend(ys, fn y => Pair(x, y), ps)))
  77     end
  78
  79 fun project1 s = replace(s,
  80                          fn Pair(x, _) => SOME x
  81                           | _ => error "project1")
  82 fun project2 s = replace(s,
  83                          fn Pair(_, y) => SOME y
  84                           | _ => error "project2")
  85
  86 fun update (c, x, y) =
  87     let fun update[] = [Pair(x, y)]
  88           | update((Pair(x', y')) :: ps) =
  89             if Elt.equals(x, x') then (Pair(x, y)) :: ps
  90             else (Pair(x', y')) :: (update ps)
  91           | update _ = error "update"
  92     in listTo(update(toList c))
  93     end
  94
  95 fun updateSet(c, c') =
  96     L.foldl(toList c', c,
  97             fn (c, Pair(x, y)) => update(c, x, y)
  98              | _ => error "updateSet")
  99
 100 fun lookup (c, x) =
 101     let fun lookup [] = NONE
 102           | lookup (Pair(x', y) :: ps) =
 103             if Elt.equals(x, x') then SOME y else lookup ps
 104           | lookup _ = error "lookup"
 105     in lookup(toList c)
 106     end
 107
 108 fun Union s = L.foldl(toList s, empty,
 109                       fn (s', Set s) => union(s, s')
 110                        | _ => error "Union")
 111 val Union = Trace.trace("Union", outputSet, outputSet) Union
 112 (*
 113 fun Cross s = listTo(L.map(L.cross(L.map(toList s,
 114                                          toList o Elt.toSet)),
 115                             Set o listTo))
 116 *)
 117 end