The Metis prover (slightly modified version from Larry);
authorwenzelm
Wed Jun 20 22:07:52 2007 +0200 (2007-06-20)
changeset 23442028e39e5e8f3
parent 23441 ee218296d635
child 23443 fd8ffc8a5709
The Metis prover (slightly modified version from Larry);
src/HOL/Metis.thy
src/HOL/Tools/metis_tools.ML
src/Tools/Metis/make-metis
src/Tools/Metis/metis-env
src/Tools/Metis/metis.ML
src/Tools/Metis/scripts/mlpp
src/Tools/Metis/src/Active.sig
src/Tools/Metis/src/Active.sml
src/Tools/Metis/src/Atom.sig
src/Tools/Metis/src/Atom.sml
src/Tools/Metis/src/AtomNet.sig
src/Tools/Metis/src/AtomNet.sml
src/Tools/Metis/src/Clause.sig
src/Tools/Metis/src/Clause.sml
src/Tools/Metis/src/ElementSet.sig
src/Tools/Metis/src/ElementSet.sml
src/Tools/Metis/src/FILES
src/Tools/Metis/src/Formula.sig
src/Tools/Metis/src/Formula.sml
src/Tools/Metis/src/Heap.sig
src/Tools/Metis/src/Heap.sml
src/Tools/Metis/src/KeyMap.sig
src/Tools/Metis/src/KeyMap.sml
src/Tools/Metis/src/KnuthBendixOrder.sig
src/Tools/Metis/src/KnuthBendixOrder.sml
src/Tools/Metis/src/Lazy.sig
src/Tools/Metis/src/Lazy.sml
src/Tools/Metis/src/Literal.sig
src/Tools/Metis/src/Literal.sml
src/Tools/Metis/src/LiteralNet.sig
src/Tools/Metis/src/LiteralNet.sml
src/Tools/Metis/src/Map.sig
src/Tools/Metis/src/Map.sml
src/Tools/Metis/src/Model.sig
src/Tools/Metis/src/Model.sml
src/Tools/Metis/src/Name.sig
src/Tools/Metis/src/Name.sml
src/Tools/Metis/src/Normalize.sig
src/Tools/Metis/src/Normalize.sml
src/Tools/Metis/src/Options.sig
src/Tools/Metis/src/Options.sml
src/Tools/Metis/src/Ordered.sig
src/Tools/Metis/src/Ordered.sml
src/Tools/Metis/src/PP.sig
src/Tools/Metis/src/PP.sml
src/Tools/Metis/src/Parser.sig
src/Tools/Metis/src/Parser.sml
src/Tools/Metis/src/Portable.sig
src/Tools/Metis/src/PortableIsabelle.sml
src/Tools/Metis/src/PortableMlton.sml
src/Tools/Metis/src/PortableMosml.sml
src/Tools/Metis/src/PortableSmlNJ.sml
src/Tools/Metis/src/Problem.sig
src/Tools/Metis/src/Problem.sml
src/Tools/Metis/src/Proof.sig
src/Tools/Metis/src/Proof.sml
src/Tools/Metis/src/Random.sig
src/Tools/Metis/src/Random.sml
src/Tools/Metis/src/RandomMap.sml
src/Tools/Metis/src/RandomSet.sml
src/Tools/Metis/src/Resolution.sig
src/Tools/Metis/src/Resolution.sml
src/Tools/Metis/src/Rewrite.sig
src/Tools/Metis/src/Rewrite.sml
src/Tools/Metis/src/Rule.sig
src/Tools/Metis/src/Rule.sml
src/Tools/Metis/src/Set.sig
src/Tools/Metis/src/Set.sml
src/Tools/Metis/src/Sharing.sig
src/Tools/Metis/src/Sharing.sml
src/Tools/Metis/src/Stream.sig
src/Tools/Metis/src/Stream.sml
src/Tools/Metis/src/Subst.sig
src/Tools/Metis/src/Subst.sml
src/Tools/Metis/src/Subsume.sig
src/Tools/Metis/src/Subsume.sml
src/Tools/Metis/src/Term.sig
src/Tools/Metis/src/Term.sml
src/Tools/Metis/src/TermNet.sig
src/Tools/Metis/src/TermNet.sml
src/Tools/Metis/src/Thm.sig
src/Tools/Metis/src/Thm.sml
src/Tools/Metis/src/Tptp.sig
src/Tools/Metis/src/Tptp.sml
src/Tools/Metis/src/Units.sig
src/Tools/Metis/src/Units.sml
src/Tools/Metis/src/Useful.sig
src/Tools/Metis/src/Useful.sml
src/Tools/Metis/src/Waiting.sig
src/Tools/Metis/src/Waiting.sml
src/Tools/Metis/src/metis.sml
src/Tools/Metis/src/problems.sml
src/Tools/Metis/src/problems2tptp.sml
src/Tools/Metis/src/selftest.sml
     1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/HOL/Metis.thy	Wed Jun 20 22:07:52 2007 +0200
     1.3 @@ -0,0 +1,16 @@
     1.4 +(*  Title:      HOL/Metis.thy
     1.5 +    ID:         $Id$
     1.6 +*)
     1.7 +
     1.8 +header {* The Metis prover (version 2.0 from 2007) *}
     1.9 +
    1.10 +theory Metis
    1.11 +imports Main
    1.12 +uses
    1.13 +  "~~/src/Tools/Metis/metis.ML"
    1.14 +  "Tools/metis_tools.ML"
    1.15 +begin
    1.16 +
    1.17 +setup MetisTools.setup
    1.18 +
    1.19 +end
     2.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     2.2 +++ b/src/HOL/Tools/metis_tools.ML	Wed Jun 20 22:07:52 2007 +0200
     2.3 @@ -0,0 +1,592 @@
     2.4 +(*  Title:      HOL/Tools/metis_tools.ML
     2.5 +    Author:     Kong W. Susanto and Lawrence C. Paulson, CU Computer Laboratory
     2.6 +    Copyright   Cambridge University 2007
     2.7 +*)
     2.8 +
     2.9 +signature METIS_TOOLS =
    2.10 +sig
    2.11 +  val type_lits: bool ref
    2.12 +  val metis_tac : Thm.thm list -> int -> Tactical.tactic
    2.13 +  val setup : theory -> theory
    2.14 +end
    2.15 +
    2.16 +structure MetisTools: METIS_TOOLS =
    2.17 +struct
    2.18 +
    2.19 +  structure Rc = ResReconstruct;
    2.20 +
    2.21 +  val type_lits = ref true;
    2.22 +
    2.23 +  (* ------------------------------------------------------------------------- *)
    2.24 +  (* Useful Theorems                                                           *)
    2.25 +  (* ------------------------------------------------------------------------- *)
    2.26 +  val EXCLUDED_MIDDLE' = read_instantiate [("R","False")] notE;
    2.27 +  val EXCLUDED_MIDDLE  = rotate_prems 1 EXCLUDED_MIDDLE';
    2.28 +  val REFL_THM         = incr_indexes 2 (Meson.make_meta_clause refl);  (*Rename from 0,1*)
    2.29 +  val subst_em  = zero_var_indexes (subst RS EXCLUDED_MIDDLE);
    2.30 +  val ssubst_em  = read_instantiate [("t","?s"),("s","?t")] (sym RS subst_em);
    2.31 +
    2.32 +  (* ------------------------------------------------------------------------- *)
    2.33 +  (* Useful Functions                                                          *)
    2.34 +  (* ------------------------------------------------------------------------- *)
    2.35 +
    2.36 +  (* match untyped terms*)
    2.37 +  fun untyped_aconv (Const(a,_))   (Const(b,_))   = (a=b)
    2.38 +    | untyped_aconv (Free(a,_))    (Free(b,_))    = (a=b)
    2.39 +    | untyped_aconv (Var((a,_),_)) (Var((b,_),_)) = (a=b)   (*the index is ignored!*)
    2.40 +    | untyped_aconv (Bound i)      (Bound j)      = (i=j)
    2.41 +    | untyped_aconv (Abs(a,_,t))  (Abs(b,_,u))    = (a=b) andalso untyped_aconv t u
    2.42 +    | untyped_aconv (t1$t2) (u1$u2)  = untyped_aconv t1 u1 andalso untyped_aconv t2 u2
    2.43 +    | untyped_aconv _              _              = false;
    2.44 +
    2.45 +  (* Finding the relative location of an untyped term within a list of terms *)
    2.46 +  fun get_index lit =
    2.47 +    let val lit = Envir.eta_contract lit
    2.48 +        fun get n [] = raise Empty
    2.49 +          | get n (x::xs) = if untyped_aconv lit (Envir.eta_contract (HOLogic.dest_Trueprop x))
    2.50 +                            then n  else get (n+1) xs
    2.51 +    in get 1 end;
    2.52 +
    2.53 +  (* ------------------------------------------------------------------------- *)
    2.54 +  (* HOL to FOL  (Isabelle to Metis)                                           *)
    2.55 +  (* ------------------------------------------------------------------------- *)
    2.56 +
    2.57 +  fun fn_isa_to_met "equal" = "="
    2.58 +    | fn_isa_to_met x       = x;
    2.59 +
    2.60 +  fun metis_lit b c args = (b, (c, args));
    2.61 +
    2.62 +  fun hol_type_to_fol (ResClause.AtomV x) = Metis.Term.Var x
    2.63 +    | hol_type_to_fol (ResClause.AtomF x) = Metis.Term.Fn(x,[])
    2.64 +    | hol_type_to_fol (ResClause.Comp(tc,tps)) = Metis.Term.Fn(tc, map hol_type_to_fol tps);
    2.65 +
    2.66 +  (*These two functions insert type literals before the real literals. That is the
    2.67 +    opposite order from TPTP linkup, but maybe OK.*)
    2.68 +
    2.69 +  fun hol_term_to_fol_FO tm =
    2.70 +    case ResHolClause.strip_comb tm of
    2.71 +        (ResHolClause.CombConst(c,_,tys), tms) =>
    2.72 +          let val tyargs = map hol_type_to_fol tys
    2.73 +              val args   = map hol_term_to_fol_FO tms
    2.74 +          in Metis.Term.Fn (c, tyargs @ args) end
    2.75 +      | (ResHolClause.CombVar(v,_), []) => Metis.Term.Var v
    2.76 +      | _ => error "hol_term_to_fol_FO";
    2.77 +
    2.78 +  fun hol_term_to_fol_HO (ResHolClause.CombVar(a, ty)) = Metis.Term.Var a
    2.79 +    | hol_term_to_fol_HO (ResHolClause.CombConst(a, ty, tylist)) =
    2.80 +        Metis.Term.Fn(fn_isa_to_met a, map hol_type_to_fol tylist)
    2.81 +    | hol_term_to_fol_HO (ResHolClause.CombApp(tm1,tm2)) =
    2.82 +         Metis.Term.Fn(".", map hol_term_to_fol_HO [tm1,tm2]);
    2.83 +
    2.84 +  fun hol_literal_to_fol true (ResHolClause.Literal (pol, tm)) =  (*first-order*)
    2.85 +        let val (ResHolClause.CombConst(p,_,tys), tms) = ResHolClause.strip_comb tm
    2.86 +            val tylits = if p = "equal" then [] else map hol_type_to_fol tys
    2.87 +            val lits = map hol_term_to_fol_FO tms
    2.88 +        in metis_lit pol (fn_isa_to_met p) (tylits @ lits) end
    2.89 +    | hol_literal_to_fol false (ResHolClause.Literal (pol, tm)) =    (*higher-order*)
    2.90 +        case ResHolClause.strip_comb tm of
    2.91 +            (ResHolClause.CombConst("equal",_,_), tms) =>
    2.92 +              metis_lit pol "=" (map hol_term_to_fol_HO tms)
    2.93 +          | _ => metis_lit pol "{}" [hol_term_to_fol_HO tm];
    2.94 +
    2.95 +  fun literals_of_hol_thm isFO  t =
    2.96 +        let val (lits, types_sorts) = ResHolClause.literals_of_term t
    2.97 +        in  (map (hol_literal_to_fol isFO) lits, types_sorts) end;
    2.98 +
    2.99 +  fun metis_of_typeLit (ResClause.LTVar (s,x))  = metis_lit false s [Metis.Term.Var x]
   2.100 +    | metis_of_typeLit (ResClause.LTFree (s,x)) = metis_lit true  s [Metis.Term.Fn(x,[])];
   2.101 +
   2.102 +  fun metis_of_tfree tf = Metis.Thm.axiom (Metis.LiteralSet.singleton (metis_of_typeLit tf));
   2.103 +
   2.104 +  fun hol_thm_to_fol isFO th =
   2.105 +    let val (mlits, types_sorts) =
   2.106 +               (literals_of_hol_thm isFO o HOLogic.dest_Trueprop o prop_of) th
   2.107 +        val (tvar_lits,tfree_lits) = ResClause.add_typs_aux types_sorts
   2.108 +        val tlits = if !type_lits then map metis_of_typeLit tvar_lits else []
   2.109 +    in  (Metis.Thm.axiom (Metis.LiteralSet.fromList(tlits@mlits)), tfree_lits)  end;
   2.110 +
   2.111 +  (* ARITY CLAUSE *)
   2.112 +
   2.113 +  fun m_arity_cls (ResClause.TConsLit (c,t,args)) =
   2.114 +        metis_lit true (ResClause.make_type_class c) [Metis.Term.Fn(t, map Metis.Term.Var args)]
   2.115 +    | m_arity_cls (ResClause.TVarLit (c,str))     =
   2.116 +        metis_lit false (ResClause.make_type_class c) [Metis.Term.Var str];
   2.117 +
   2.118 +  (*TrueI is returned as the Isabelle counterpart because there isn't any.*)
   2.119 +  fun arity_cls thy (ResClause.ArityClause{kind,conclLit,premLits,...}) =
   2.120 +    (TrueI, Metis.Thm.axiom (Metis.LiteralSet.fromList (map m_arity_cls (conclLit :: premLits))));
   2.121 +
   2.122 +  (* CLASSREL CLAUSE *)
   2.123 +
   2.124 +  fun m_classrel_cls subclass superclass =
   2.125 +    [metis_lit false subclass [Metis.Term.Var "T"], metis_lit true superclass [Metis.Term.Var "T"]];
   2.126 +
   2.127 +  fun classrel_cls thy (ResClause.ClassrelClause {axiom_name,subclass,superclass,...}) =
   2.128 +    (TrueI, Metis.Thm.axiom (Metis.LiteralSet.fromList (m_classrel_cls subclass superclass)));
   2.129 +
   2.130 +  (* ------------------------------------------------------------------------- *)
   2.131 +  (* FOL to HOL  (Metis to Isabelle)                                           *)
   2.132 +  (* ------------------------------------------------------------------------- *)
   2.133 +
   2.134 + datatype term_or_type = Term of Term.term | Type of Term.typ;
   2.135 +
   2.136 +  fun terms_of [] = []
   2.137 +    | terms_of (Term t :: tts) = t :: terms_of tts
   2.138 +    | terms_of (Type _ :: tts) = terms_of tts;
   2.139 +
   2.140 +  fun types_of [] = []
   2.141 +    | types_of (Term (Term.Var((a,idx), T)) :: tts) =
   2.142 +        if String.isPrefix "_" a then
   2.143 +            (*Variable generated by Metis, which might have been a type variable.*)
   2.144 +            TVar(("'" ^ a, idx), HOLogic.typeS) :: types_of tts
   2.145 +        else types_of tts
   2.146 +    | types_of (Term _ :: tts) = types_of tts
   2.147 +    | types_of (Type T :: tts) = T :: types_of tts;
   2.148 +
   2.149 +  fun apply_list rator nargs rands =
   2.150 +    let val trands = terms_of rands
   2.151 +    in  if length trands = nargs then Term (list_comb(rator, trands))
   2.152 +        else error ("apply_list: wrong number of arguments: " ^ Display.raw_string_of_term rator ^
   2.153 +                    " expected " ^
   2.154 +                    Int.toString nargs ^ " received " ^ commas (map Display.raw_string_of_term trands))
   2.155 +    end;
   2.156 +
   2.157 +(*Instantiate constant c with the supplied types, but if they don't match its declared
   2.158 +  sort constraints, replace by a general type.*)
   2.159 +fun const_of ctxt (c,Ts) =  Const (c, dummyT)
   2.160 +(*Formerly, this code was used. Now, we just leave it all to type inference!
   2.161 +  let val thy = ProofContext.theory_of ctxt
   2.162 +      and (types, sorts) = Variable.constraints_of ctxt
   2.163 +      val declaredT = Consts.the_constraint (Sign.consts_of thy) c
   2.164 +      val t = Rc.fix_sorts sorts (Const(c, Sign.const_instance thy (c,Ts)))
   2.165 +  in
   2.166 +      Sign.typ_match thy (declaredT, type_of t) Vartab.empty;
   2.167 +      t
   2.168 +  end
   2.169 +  handle Type.TYPE_MATCH => Const (c, dummyT);
   2.170 +*)
   2.171 +
   2.172 +  (*We use 1 rather than 0 because variable references in clauses may otherwise conflict
   2.173 +    with variable constraints in the goal...at least, type inference often fails otherwise.
   2.174 +    SEE ALSO axiom_inf below.*)
   2.175 +  fun mk_var w = Term.Var((w,1), HOLogic.typeT);
   2.176 +
   2.177 +  (*include the default sort, if available*)
   2.178 +  fun mk_tfree ctxt w =
   2.179 +    let val ww = "'" ^ w
   2.180 +    in  TFree(ww, getOpt (Variable.def_sort ctxt (ww,~1), HOLogic.typeS))  end;
   2.181 +
   2.182 +  (*Remove the "apply" operator from an HO term*)
   2.183 +  fun strip_happ args (Metis.Term.Fn(".",[t,u])) = strip_happ (u::args) t
   2.184 +    | strip_happ args x = (x, args);
   2.185 +
   2.186 +  (*Maps metis terms to isabelle terms*)
   2.187 +  fun fol_term_to_hol_RAW ctxt fol_tm =
   2.188 +    let val thy = ProofContext.theory_of ctxt
   2.189 +        val _ = Output.debug (fn () => "fol_term_to_hol: " ^ Metis.Term.toString fol_tm)
   2.190 +        fun tm_to_tt (Metis.Term.Var v) =
   2.191 +               (case Rc.strip_prefix ResClause.tvar_prefix v of
   2.192 +                    SOME w => Type (Rc.make_tvar w)
   2.193 +                  | NONE =>
   2.194 +                case Rc.strip_prefix ResClause.schematic_var_prefix v of
   2.195 +                    SOME w => Term (mk_var w)
   2.196 +                  | NONE   => Term (mk_var v) )
   2.197 +                      (*Var from Metis with a name like _nnn; possibly a type variable*)
   2.198 +          | tm_to_tt (Metis.Term.Fn ("{}", [arg])) = tm_to_tt arg   (*hBOOL*)
   2.199 +          | tm_to_tt (t as Metis.Term.Fn (".",_)) =
   2.200 +              let val (rator,rands) = strip_happ [] t
   2.201 +              in  case rator of
   2.202 +                      Metis.Term.Fn(fname,ts) => applic_to_tt (fname, ts @ rands)
   2.203 +                    | _ => case tm_to_tt rator of
   2.204 +                               Term t => Term (list_comb(t, terms_of (map tm_to_tt rands)))
   2.205 +                             | _ => error "tm_to_tt: HO application"
   2.206 +              end
   2.207 +          | tm_to_tt (Metis.Term.Fn (fname, args)) = applic_to_tt (fname,args)
   2.208 +        and applic_to_tt ("=",ts) =
   2.209 +              Term (list_comb(Const ("op =", HOLogic.typeT), terms_of (map tm_to_tt ts)))
   2.210 +          | applic_to_tt (a,ts) =
   2.211 +              case Rc.strip_prefix ResClause.const_prefix a of
   2.212 +                  SOME b =>
   2.213 +                    let val c = Rc.invert_const b
   2.214 +                        val ntypes = Rc.num_typargs thy c
   2.215 +                        val nterms = length ts - ntypes
   2.216 +                        val tts = map tm_to_tt ts
   2.217 +                        val tys = types_of (List.take(tts,ntypes))
   2.218 +                        val ntyargs = Rc.num_typargs thy c
   2.219 +                    in if length tys = ntyargs then
   2.220 +                           apply_list (const_of ctxt (c, tys)) nterms (List.drop(tts,ntypes))
   2.221 +                       else error ("Constant " ^ c ^ " expects " ^ Int.toString ntyargs ^
   2.222 +                                   " but gets " ^ Int.toString (length tys) ^
   2.223 +                                   " type arguments\n" ^
   2.224 +                                   space_implode "\n" (map (ProofContext.string_of_typ ctxt) tys) ^
   2.225 +                                   " the terms are \n" ^
   2.226 +                                   space_implode "\n" (map (ProofContext.string_of_term ctxt) (terms_of tts)))
   2.227 +                       end
   2.228 +                | NONE => (*Not a constant. Is it a type constructor?*)
   2.229 +              case Rc.strip_prefix ResClause.tconst_prefix a of
   2.230 +                  SOME b => Type (Term.Type(Rc.invert_type_const b, types_of (map tm_to_tt ts)))
   2.231 +                | NONE => (*Maybe a TFree. Should then check that ts=[].*)
   2.232 +              case Rc.strip_prefix ResClause.tfree_prefix a of
   2.233 +                  SOME b => Type (mk_tfree ctxt b)
   2.234 +                | NONE => (*a fixed variable? They are Skolem functions.*)
   2.235 +              case Rc.strip_prefix ResClause.fixed_var_prefix a of
   2.236 +                  SOME b =>
   2.237 +                    let val opr = Term.Free(b, HOLogic.typeT)
   2.238 +                    in  apply_list opr (length ts) (map tm_to_tt ts)  end
   2.239 +                | NONE => error ("unexpected metis function: " ^ a)
   2.240 +    in  case tm_to_tt fol_tm of Term t => t | _ => error "fol_tm_to_tt: Term expected"  end;
   2.241 +
   2.242 +  fun fol_terms_to_hol ctxt fol_tms =
   2.243 +    let val ts = map (fol_term_to_hol_RAW ctxt) fol_tms
   2.244 +        val _ = Output.debug (fn () => "  calling infer_types:")
   2.245 +        val _ = app (fn t => Output.debug (fn () => ProofContext.string_of_term ctxt t)) ts
   2.246 +        val ts' = ProofContext.infer_types_pats ctxt ts
   2.247 +                    (*DO NOT freeze TVars in the result*)
   2.248 +        val _ = app (fn t => Output.debug
   2.249 +                      (fn () => "  final term: " ^ ProofContext.string_of_term ctxt t ^
   2.250 +                                "  of type  " ^ ProofContext.string_of_typ ctxt (type_of t)))
   2.251 +                    ts'
   2.252 +    in  ts'  end;
   2.253 +
   2.254 +  fun mk_not (Const ("Not", _) $ b) = b
   2.255 +    | mk_not b = HOLogic.mk_not b;
   2.256 +
   2.257 +  (* ------------------------------------------------------------------------- *)
   2.258 +  (* FOL step Inference Rules                                                  *)
   2.259 +  (* ------------------------------------------------------------------------- *)
   2.260 +
   2.261 +  (*for debugging only*)
   2.262 +  fun print_thpair (fth,th) =
   2.263 +    (Output.debug (fn () => "=============================================");
   2.264 +     Output.debug (fn () => "Metis: " ^ Metis.Thm.toString fth);
   2.265 +     Output.debug (fn () => "Isabelle: " ^ string_of_thm th));
   2.266 +
   2.267 +  fun lookth thpairs (fth : Metis.Thm.thm) =
   2.268 +    valOf (AList.lookup (uncurry Metis.Thm.equal) thpairs fth)
   2.269 +    handle Option => error ("Failed to find a Metis theorem " ^ Metis.Thm.toString fth);
   2.270 +
   2.271 +  fun is_TrueI th = Thm.eq_thm(TrueI,th);
   2.272 +
   2.273 +fun inst_excluded_middle th thy i_atm =
   2.274 +    let val vx = hd (term_vars (prop_of th))
   2.275 +        val substs = [(cterm_of thy vx, cterm_of thy i_atm)]
   2.276 +    in  cterm_instantiate substs th  end;
   2.277 +
   2.278 +  (* INFERENCE RULE: AXIOM *)
   2.279 +  fun axiom_inf ctxt thpairs th = incr_indexes 1 (lookth thpairs th);
   2.280 +      (*This causes variables to have an index of 1 by default. SEE ALSO mk_var above.*)
   2.281 +
   2.282 +  (* INFERENCE RULE: ASSUME *)
   2.283 +  fun assume_inf ctxt atm =
   2.284 +    inst_excluded_middle EXCLUDED_MIDDLE
   2.285 +      (ProofContext.theory_of ctxt)
   2.286 +      (singleton (fol_terms_to_hol ctxt) (Metis.Term.Fn atm));
   2.287 +
   2.288 +  (* INFERENCE RULE: INSTANTIATE. Type instantiations are ignored. Attempting to reconstruct
   2.289 +     them admits new possibilities of errors, e.g. concerning sorts. Instead we try to arrange
   2.290 +     that new TVars are distinct and that types can be inferred from terms.*)
   2.291 +  fun inst_inf ctxt thpairs fsubst th =
   2.292 +    let val thy = ProofContext.theory_of ctxt
   2.293 +        val i_th   = lookth thpairs th
   2.294 +        val i_th_vars = term_vars (prop_of i_th)
   2.295 +        fun find_var x = valOf (List.find (fn Term.Var((a,_),_) => a=x) i_th_vars)
   2.296 +        fun subst_translation (x,y) =
   2.297 +              let val v = find_var x
   2.298 +                  val t = fol_term_to_hol_RAW ctxt y
   2.299 +              in  SOME (cterm_of thy v, t)  end
   2.300 +              handle Option => NONE (*List.find failed for the variable.*)
   2.301 +        fun remove_typeinst (a, t) =
   2.302 +              case Rc.strip_prefix ResClause.schematic_var_prefix a of
   2.303 +                  SOME b => SOME (b, t)
   2.304 +                | NONE   => case Rc.strip_prefix ResClause.tvar_prefix a of
   2.305 +                  SOME _ => NONE          (*type instantiations are forbidden!*)
   2.306 +                | NONE   => SOME (a,t)    (*internal Metis var?*)
   2.307 +        val _ = Output.debug (fn () => "  isa th: " ^ string_of_thm i_th)
   2.308 +        val substs = List.mapPartial remove_typeinst (Metis.Subst.toList fsubst)
   2.309 +        val (vars,rawtms) = ListPair.unzip (List.mapPartial subst_translation substs)
   2.310 +        val tms = ProofContext.infer_types_pats ctxt rawtms
   2.311 +        val ctm_of = cterm_of thy o (map_types o Logic.incr_tvar) (1 + Thm.maxidx_of i_th)
   2.312 +        val substs' = ListPair.zip (vars, map ctm_of tms)
   2.313 +        val _ = Output.debug (fn() => "subst_translations:")
   2.314 +        val _ = app (fn (x,y) => Output.debug (fn () => string_of_cterm x ^ " |-> " ^
   2.315 +                                                        string_of_cterm y))
   2.316 +                  substs'
   2.317 +    in  cterm_instantiate substs' i_th  end;
   2.318 +
   2.319 +  (* INFERENCE RULE: RESOLVE *)
   2.320 +
   2.321 +  fun resolve_inf ctxt thpairs atm th1 th2 =
   2.322 +    let
   2.323 +      val thy = ProofContext.theory_of ctxt
   2.324 +      val i_th1 = lookth thpairs th1 and i_th2 = lookth thpairs th2
   2.325 +      val _ = Output.debug (fn () => "  isa th1 (pos): " ^ string_of_thm i_th1)
   2.326 +      val _ = Output.debug (fn () => "  isa th2 (neg): " ^ string_of_thm i_th2)
   2.327 +    in
   2.328 +      if is_TrueI i_th1 then i_th2 (*Trivial cases where one operand is type info*)
   2.329 +      else if is_TrueI i_th2 then i_th1
   2.330 +      else
   2.331 +        let
   2.332 +          val i_atm = singleton (fol_terms_to_hol ctxt) (Metis.Term.Fn atm)
   2.333 +          val _ = Output.debug (fn () => "  atom: " ^ ProofContext.string_of_term ctxt i_atm)
   2.334 +          val prems_th1 = prems_of i_th1
   2.335 +          val prems_th2 = prems_of i_th2
   2.336 +          val index_th1 = get_index (mk_not i_atm) prems_th1
   2.337 +                handle Empty => error "Failed to find literal in th1"
   2.338 +          val _ = Output.debug (fn () => "  index_th1: " ^ Int.toString index_th1)
   2.339 +          val index_th2 = get_index i_atm prems_th2
   2.340 +                handle Empty => error "Failed to find literal in th2"
   2.341 +          val _ = Output.debug (fn () => "  index_th2: " ^ Int.toString index_th2)
   2.342 +      in  (select_literal index_th1 i_th1) RSN (index_th2, i_th2)  end
   2.343 +    end;
   2.344 +
   2.345 +  (* INFERENCE RULE: REFL *)
   2.346 +  fun refl_inf ctxt lit =
   2.347 +    let val thy = ProofContext.theory_of ctxt
   2.348 +        val v_x = hd (term_vars (prop_of REFL_THM))
   2.349 +        val i_lit = singleton (fol_terms_to_hol ctxt) lit
   2.350 +    in  cterm_instantiate [(cterm_of thy v_x, cterm_of thy i_lit)] REFL_THM  end;
   2.351 +
   2.352 +  fun get_ty_arg_size thy (Const("op =",_)) = 0  (*equality has no type arguments*)
   2.353 +    | get_ty_arg_size thy (Const(c,_))      = (Rc.num_typargs thy c handle TYPE _ => 0)
   2.354 +    | get_ty_arg_size thy _      = 0;
   2.355 +
   2.356 +  (* INFERENCE RULE: EQUALITY *)
   2.357 +  fun equality_inf ctxt isFO thpairs (pos,atm) fp fr =
   2.358 +    let val thy = ProofContext.theory_of ctxt
   2.359 +        val [i_atm,i_tm] = fol_terms_to_hol ctxt [Metis.Term.Fn atm, fr]
   2.360 +        val _ = Output.debug (fn () => "sign of the literal: " ^ Bool.toString pos)
   2.361 +        fun replace_item_list lx 0 (l::ls) = lx::ls
   2.362 +          | replace_item_list lx i (l::ls) = l :: replace_item_list lx (i-1) ls
   2.363 +        fun path_finder_FO tm (p::ps) =
   2.364 +              let val (tm1,args) = Term.strip_comb tm
   2.365 +                  val adjustment = get_ty_arg_size thy tm1
   2.366 +                  val p' = if adjustment > p then p else p-adjustment
   2.367 +                  val tm_p = List.nth(args,p')
   2.368 +                    handle Subscript => error ("equality_inf: " ^ Int.toString p ^ " adj " ^ Int.toString adjustment  ^ " term " ^  ProofContext.string_of_term ctxt tm)
   2.369 +              in
   2.370 +                  Output.debug (fn () => "path_finder: " ^ Int.toString p ^
   2.371 +                                        "  " ^ ProofContext.string_of_term ctxt tm_p);
   2.372 +                  if null ps   (*FIXME: why not use pattern-matching and avoid repetition*)
   2.373 +                  then (tm_p, list_comb (tm1, replace_item_list (Term.Bound 0) p' args))
   2.374 +                  else let val (r,t) = path_finder_FO tm_p ps
   2.375 +                       in (r, list_comb (tm1, replace_item_list t p' args)) end
   2.376 +              end
   2.377 +        fun path_finder_HO tm [] = (tm, Term.Bound 0)
   2.378 +          | path_finder_HO (t$u) (0::ps) = (fn(x,y) => (x, y$u)) (path_finder_HO t ps)
   2.379 +          | path_finder_HO (t$u) (p::ps) = (fn(x,y) => (x, t$y)) (path_finder_HO u ps)
   2.380 +        fun path_finder true tm ps = path_finder_FO tm ps
   2.381 +          | path_finder false (tm as Const("op =",_) $ _ $ _) (p::ps) =
   2.382 +               (*equality: not curried, as other predicates are*)
   2.383 +               if p=0 then path_finder_HO tm (0::1::ps)  (*select first operand*)
   2.384 +               else path_finder_HO tm (p::ps)        (*1 selects second operand*)
   2.385 +          | path_finder false tm (p::ps) =
   2.386 +               path_finder_HO tm ps      (*if not equality, ignore head to skip hBOOL*)
   2.387 +        fun path_finder_lit ((nt as Term.Const ("Not", _)) $ tm_a) idx =
   2.388 +              let val (tm, tm_rslt) = path_finder isFO tm_a idx
   2.389 +              in (tm, nt $ tm_rslt) end
   2.390 +          | path_finder_lit tm_a idx = path_finder isFO tm_a idx
   2.391 +        val (tm_subst, body) = path_finder_lit i_atm fp
   2.392 +        val tm_abs = Term.Abs("x", Term.type_of tm_subst, body)
   2.393 +        val _ = Output.debug (fn () => "abstraction: " ^ ProofContext.string_of_term ctxt tm_abs)
   2.394 +        val _ = Output.debug (fn () => "i_tm: " ^ ProofContext.string_of_term ctxt i_tm)
   2.395 +        val _ = Output.debug (fn () => "located term: " ^ ProofContext.string_of_term ctxt tm_subst)
   2.396 +        val imax = maxidx_of_term (i_tm $ tm_abs $ tm_subst)  (*ill typed but gives right max*)
   2.397 +        val subst' = incr_indexes (imax+1) (if pos then subst_em else ssubst_em)
   2.398 +        val _ = Output.debug (fn () => "subst' " ^ string_of_thm subst')
   2.399 +        val eq_terms = map (pairself (cterm_of thy))
   2.400 +                           (ListPair.zip (term_vars (prop_of subst'), [tm_abs, tm_subst, i_tm]))
   2.401 +    in  cterm_instantiate eq_terms subst'  end;
   2.402 +
   2.403 +  fun step ctxt isFO thpairs (fol_th, Metis.Proof.Axiom _)                        =
   2.404 +        axiom_inf ctxt thpairs fol_th
   2.405 +    | step ctxt isFO thpairs (_, Metis.Proof.Assume f_atm)                        =
   2.406 +        assume_inf ctxt f_atm
   2.407 +    | step ctxt isFO thpairs (_, Metis.Proof.Subst(f_subst, f_th1))                =
   2.408 +        inst_inf ctxt thpairs f_subst f_th1
   2.409 +    | step ctxt isFO thpairs (_, Metis.Proof.Resolve(f_atm, f_th1, f_th2))        =
   2.410 +        resolve_inf ctxt thpairs f_atm f_th1 f_th2
   2.411 +    | step ctxt isFO thpairs (_, Metis.Proof.Refl f_tm)                           =
   2.412 +        refl_inf ctxt f_tm
   2.413 +    | step ctxt isFO thpairs (_, Metis.Proof.Equality(f_lit, f_p, f_r)) =
   2.414 +        equality_inf ctxt isFO thpairs f_lit f_p f_r;
   2.415 +
   2.416 +  val factor = Seq.hd o distinct_subgoals_tac;
   2.417 +
   2.418 +  fun real_literal (b, (c, _)) = not (String.isPrefix ResClause.class_prefix c);
   2.419 +
   2.420 +  fun translate isFO _    thpairs [] = thpairs
   2.421 +    | translate isFO ctxt thpairs ((fol_th, inf) :: infpairs) =
   2.422 +        let val _ = Output.debug (fn () => "=============================================")
   2.423 +            val _ = Output.debug (fn () => "METIS THM: " ^ Metis.Thm.toString fol_th)
   2.424 +            val _ = Output.debug (fn () => "INFERENCE: " ^ Metis.Proof.inferenceToString inf)
   2.425 +            val th = Meson.flexflex_first_order (factor (step ctxt isFO thpairs (fol_th, inf)))
   2.426 +            val _ = Output.debug (fn () => "ISABELLE THM: " ^ string_of_thm th)
   2.427 +            val _ = Output.debug (fn () => "=============================================")
   2.428 +        in
   2.429 +            if nprems_of th =
   2.430 +        length (filter real_literal (Metis.LiteralSet.toList (Metis.Thm.clause fol_th))) then ()
   2.431 +            else error "Metis: proof reconstruction has gone wrong";
   2.432 +            translate isFO ctxt ((fol_th, th) :: thpairs) infpairs
   2.433 +        end;
   2.434 +
   2.435 +  (* ------------------------------------------------------------------------- *)
   2.436 +  (* Translation of HO Clauses                                                 *)
   2.437 +  (* ------------------------------------------------------------------------- *)
   2.438 +
   2.439 +  fun cnf_th th = hd (ResAxioms.cnf_axiom th);
   2.440 +
   2.441 +  val equal_imp_fequal' = cnf_th (thm"equal_imp_fequal");
   2.442 +  val fequal_imp_equal' = cnf_th (thm"fequal_imp_equal");
   2.443 +
   2.444 +  val comb_I  = ResHolClause.comb_I  RS meta_eq_to_obj_eq;
   2.445 +  val comb_K  = ResHolClause.comb_K  RS meta_eq_to_obj_eq;
   2.446 +  val comb_B  = ResHolClause.comb_B  RS meta_eq_to_obj_eq;
   2.447 +
   2.448 +  val ext_thm = cnf_th ResHolClause.ext;
   2.449 +
   2.450 +  fun dest_Arity (ResClause.ArityClause{premLits,...}) =
   2.451 +        map ResClause.class_of_arityLit premLits;
   2.452 +
   2.453 +  fun type_ext thy tms =
   2.454 +    let val subs = ResAtp.tfree_classes_of_terms tms
   2.455 +        val supers = ResAtp.tvar_classes_of_terms tms
   2.456 +        and tycons = ResAtp.type_consts_of_terms thy tms
   2.457 +        val arity_clauses = ResClause.make_arity_clauses thy tycons supers
   2.458 +        val (supers',arity_clauses) = ResClause.make_arity_clauses thy tycons supers
   2.459 +        val classrel_clauses = ResClause.make_classrel_clauses thy subs supers'
   2.460 +    in  map (classrel_cls thy) classrel_clauses @ map (arity_cls thy) arity_clauses
   2.461 +    end;
   2.462 +
   2.463 +  (* ------------------------------------------------------------------------- *)
   2.464 +  (* Logic maps manage the interface between HOL and first-order logic.        *)
   2.465 +  (* ------------------------------------------------------------------------- *)
   2.466 +
   2.467 +  type logic_map =
   2.468 +    {isFO   : bool,
   2.469 +     axioms : (Metis.Thm.thm * Thm.thm) list,
   2.470 +     tfrees : ResClause.type_literal list};
   2.471 +
   2.472 +  fun const_in_metis c (pol,(pred,tm_list)) =
   2.473 +    let
   2.474 +      fun in_mterm (Metis.Term.Var nm) = false
   2.475 +        | in_mterm (Metis.Term.Fn (".", tm_list)) = exists in_mterm tm_list
   2.476 +        | in_mterm (Metis.Term.Fn (nm, tm_list)) = c=nm orelse exists in_mterm tm_list
   2.477 +    in  c=pred orelse exists in_mterm tm_list  end;
   2.478 +
   2.479 +  (*transform isabelle clause to metis clause *)
   2.480 +  fun add_thm thy (ith, {isFO, axioms, tfrees}) : logic_map =
   2.481 +    let val (mth, tfree_lits) = hol_thm_to_fol isFO ith
   2.482 +        fun add_tfree (tf, axs) =
   2.483 +              if member (op=) tfrees tf then axs
   2.484 +              else (metis_of_tfree tf, TrueI) :: axs
   2.485 +        val new_axioms = foldl add_tfree [] tfree_lits
   2.486 +    in
   2.487 +       {isFO = isFO,
   2.488 +        axioms = (mth, Meson.make_meta_clause ith) :: (new_axioms @ axioms),
   2.489 +        tfrees = tfree_lits union tfrees}
   2.490 +    end;
   2.491 +
   2.492 +  (*transform isabelle type / arity clause to metis clause *)
   2.493 +  fun add_type_thm [] lmap = lmap
   2.494 +    | add_type_thm ((ith, mth) :: cls) {isFO, axioms, tfrees} =
   2.495 +        add_type_thm cls {isFO = isFO,
   2.496 +                          axioms = (mth, ith) :: axioms,
   2.497 +                          tfrees = tfrees}
   2.498 +
   2.499 +  (* Function to generate metis clauses, including comb and type clauses *)
   2.500 +  fun build_map mode thy cls ths =
   2.501 +    let val isFO = (mode = ResAtp.Fol) orelse
   2.502 +                    (mode <> ResAtp.Hol andalso ResAtp.is_fol_thms (cls @ ths))
   2.503 +        val lmap = foldl (add_thm thy) {isFO = isFO, axioms = [], tfrees = []} (cls @ ths)
   2.504 +        val clause_lists = map (Metis.Thm.clause o #1) (#axioms lmap)
   2.505 +        fun used c = exists (Metis.LiteralSet.exists (const_in_metis c)) clause_lists
   2.506 +        (*Now check for the existence of certain combinators*)
   2.507 +        val IK    = if used "c_COMBI" orelse used "c_COMBK" then [comb_I,comb_K] else []
   2.508 +        val BC    = if used "c_COMBB" then [comb_B] else []
   2.509 +        val EQ    = if used "c_fequal" then [fequal_imp_equal', equal_imp_fequal'] else []
   2.510 +        val lmap' = if isFO then lmap else foldl (add_thm thy) lmap ([ext_thm] @ EQ @ IK @ BC)
   2.511 +    in
   2.512 +        add_type_thm (type_ext thy (map prop_of (cls @ ths))) lmap'
   2.513 +    end;
   2.514 +
   2.515 +  fun refute cls =
   2.516 +      Metis.Resolution.loop (Metis.Resolution.new Metis.Resolution.default cls);
   2.517 +
   2.518 +  fun is_false t = t aconv (HOLogic.mk_Trueprop HOLogic.false_const);
   2.519 +
   2.520 +  (* Main function to start metis prove and reconstruction *)
   2.521 +  fun FOL_SOLVE mode ctxt cls ths =
   2.522 +    let val thy = ProofContext.theory_of ctxt
   2.523 +        val _ = if exists(is_false o prop_of) cls then error "problem contains the empty clause"
   2.524 +                else ();
   2.525 +        val _ = ResClause.init thy
   2.526 +        val _ = ResHolClause.init thy
   2.527 +        val _ = Output.debug (fn () => "FOL_SOLVE: CONJECTURE CLAUSES")
   2.528 +        val _ = app (fn th => Output.debug (fn () => string_of_thm th)) cls
   2.529 +        val _ = Output.debug (fn () => "THEOREM CLAUSES")
   2.530 +        val _ = app (fn th => Output.debug (fn () => string_of_thm th)) ths
   2.531 +        val {isFO,axioms,tfrees} = build_map mode thy cls ths
   2.532 +        val _ = if null tfrees then ()
   2.533 +                else (Output.debug (fn () => "TFREE CLAUSES");
   2.534 +                      app (fn tf => Output.debug (fn _ => ResClause.tptp_of_typeLit tf)) tfrees)
   2.535 +        val _ = Output.debug (fn () => "CLAUSES GIVEN TO METIS")
   2.536 +        val thms = map #1 axioms
   2.537 +        val _ = app (fn th => Output.debug (fn () => Metis.Thm.toString th)) thms
   2.538 +        val _ = if isFO
   2.539 +                then Output.debug (fn () => "goal is first-order")
   2.540 +                else Output.debug (fn () => "goal is higher-order")
   2.541 +        val _ = Output.debug (fn () => "START METIS PROVE PROCESS")
   2.542 +    in
   2.543 +        case refute thms of
   2.544 +            Metis.Resolution.Contradiction mth =>
   2.545 +              let val _ = Output.debug (fn () => "METIS RECONSTRUCTION START: " ^
   2.546 +                            Metis.Thm.toString mth)
   2.547 +                  val ctxt' = fold Variable.declare_constraints (map prop_of cls) ctxt
   2.548 +                               (*add constraints arising from converting goal to clause form*)
   2.549 +                  val result = translate isFO ctxt' axioms (Metis.Proof.proof mth)
   2.550 +                  val _ = Output.debug (fn () => "METIS COMPLETED")
   2.551 +              in
   2.552 +                  case result of
   2.553 +                      (_,ith)::_ => (Output.debug (fn () => "success: " ^ string_of_thm ith); ith)
   2.554 +                    | _ => error "METIS: no result"
   2.555 +              end
   2.556 +          | Metis.Resolution.Satisfiable _ => error "Metis finds the theorem to be invalid"
   2.557 +    end;
   2.558 +
   2.559 +  fun metis_general_tac mode ctxt ths i st0 =
   2.560 +    let val _ = Output.debug (fn () => "Metis called with theorems " ^ cat_lines (map string_of_thm ths))
   2.561 +        val ths' = ResAxioms.cnf_rules_of_ths ths
   2.562 +    in
   2.563 +       (MESON ResAxioms.neg_clausify (fn cls => rtac (FOL_SOLVE mode ctxt cls ths') 1) i
   2.564 +        THEN ResAxioms.expand_defs_tac st0) st0
   2.565 +    end;
   2.566 +
   2.567 +  fun metis_tac ths gno st =
   2.568 +    metis_general_tac ResAtp.Auto (ProofContext.init (theory_of_thm st)) ths gno st;
   2.569 +
   2.570 +  fun metisF_tac ths gno st =
   2.571 +    metis_general_tac ResAtp.Fol (ProofContext.init (theory_of_thm st)) ths gno st;
   2.572 +
   2.573 +  fun metisH_tac ths gno st =
   2.574 +    metis_general_tac ResAtp.Hol (ProofContext.init (theory_of_thm st)) ths gno st;
   2.575 +
   2.576 +  fun metis_meth mode ths ctxt =
   2.577 +    Method.SIMPLE_METHOD'
   2.578 +      (setmp ResHolClause.typ_level ResHolClause.T_CONST  (*constant-typed*)
   2.579 +        (setmp ResHolClause.minimize_applies false        (*avoid this optimization*)
   2.580 +          (CHANGED_PROP o metis_general_tac mode ctxt ths)));
   2.581 +
   2.582 +  fun metis  ths ctxt = metis_meth ResAtp.Auto ths ctxt;
   2.583 +  fun metisF ths ctxt = metis_meth ResAtp.Fol  ths ctxt;
   2.584 +  fun metisH ths ctxt = metis_meth ResAtp.Hol  ths ctxt;
   2.585 +
   2.586 +  val setup =
   2.587 +    Method.add_methods
   2.588 +      [("metis",  Method.thms_ctxt_args metis,  "METIS for FOL & HOL problems"),
   2.589 +       ("metisF", Method.thms_ctxt_args metisF, "METIS for FOL problems"),
   2.590 +       ("metisH", Method.thms_ctxt_args metisH, "METIS for HOL problems"),
   2.591 +       ("finish_clausify",
   2.592 +         Method.no_args (Method.SIMPLE_METHOD' (K (ResAxioms.expand_defs_tac refl))),
   2.593 +    "cleanup after conversion to clauses")];
   2.594 +
   2.595 +end;
     3.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.2 +++ b/src/Tools/Metis/make-metis	Wed Jun 20 22:07:52 2007 +0200
     3.3 @@ -0,0 +1,51 @@
     3.4 +#!/usr/bin/env bash
     3.5 +#
     3.6 +# $Id$
     3.7 +#
     3.8 +# make-metis - turn original Metis files into Isabelle ML source.
     3.9 +#
    3.10 +# Structure declarations etc. are made local by wrapping into a
    3.11 +# collective structure Metis.  Signature and functor definitions are
    3.12 +# global!
    3.13 +
    3.14 +THIS=$(cd "$(dirname "$0")"; echo $PWD)
    3.15 +
    3.16 +(
    3.17 +  cat <<EOF
    3.18 +(******************************************************************)
    3.19 +(* GENERATED FILE -- DO NOT EDIT -- GENERATED FILE -- DO NOT EDIT *)
    3.20 +(* GENERATED FILE -- DO NOT EDIT -- GENERATED FILE -- DO NOT EDIT *)
    3.21 +(* GENERATED FILE -- DO NOT EDIT -- GENERATED FILE -- DO NOT EDIT *)
    3.22 +(******************************************************************)
    3.23 +
    3.24 +print_depth 0;
    3.25 +
    3.26 +structure Metis = struct end;
    3.27 +EOF
    3.28 +
    3.29 +  for FILE in $(cat "$THIS/src/FILES")
    3.30 +  do
    3.31 +    echo
    3.32 +    echo "(**** Original file: $FILE ****)"
    3.33 +    echo
    3.34 +    if [ "$(basename "$FILE" .sig)" != "$FILE" ]
    3.35 +    then
    3.36 +      echo -e "$FILE (global)" >&2
    3.37 +      "$THIS/scripts/mlpp" -c isabelle "src/$FILE" | \
    3.38 +      perl -p -e 's/\b([A-Za-z]+\.[A-Za-z]+)/Metis.\1/g;' -e 's/\bfrag\b/Metis.frag/;'
    3.39 +    elif fgrep -q functor "src/$FILE"
    3.40 +    then
    3.41 +      "$THIS/scripts/mlpp" -c isabelle "src/$FILE" | \
    3.42 +      perl -p -e 's/ union / op union /g;' -e 's/ subset / op subset /g;'
    3.43 +    else
    3.44 +      echo -e "$FILE (local)" >&2
    3.45 +      echo "structure Metis = struct open Metis"
    3.46 +      cat < "metis-env"
    3.47 +      "$THIS/scripts/mlpp" -c isabelle "src/$FILE"
    3.48 +      echo "end;"
    3.49 +    fi
    3.50 +  done
    3.51 +
    3.52 +  echo "print_depth 10;"
    3.53 +
    3.54 +) > metis.ML
     4.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.2 +++ b/src/Tools/Metis/metis-env	Wed Jun 20 22:07:52 2007 +0200
     4.3 @@ -0,0 +1,5 @@
     4.4 +(* Metis-specific ML environment *)
     4.5 +nonfix ++ -- RL mem union subset;
     4.6 +val explode = String.explode;
     4.7 +val implode = String.implode;
     4.8 +val print = TextIO.print;
     5.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.2 +++ b/src/Tools/Metis/metis.ML	Wed Jun 20 22:07:52 2007 +0200
     5.3 @@ -0,0 +1,17459 @@
     5.4 +(******************************************************************)
     5.5 +(* GENERATED FILE -- DO NOT EDIT -- GENERATED FILE -- DO NOT EDIT *)
     5.6 +(* GENERATED FILE -- DO NOT EDIT -- GENERATED FILE -- DO NOT EDIT *)
     5.7 +(* GENERATED FILE -- DO NOT EDIT -- GENERATED FILE -- DO NOT EDIT *)
     5.8 +(******************************************************************)
     5.9 +
    5.10 +print_depth 0;
    5.11 +
    5.12 +structure Metis = struct end;
    5.13 +
    5.14 +(**** Original file: Portable.sig ****)
    5.15 +
    5.16 +(* ========================================================================= *)
    5.17 +(* ML SPECIFIC FUNCTIONS                                                     *)
    5.18 +(* Copyright (c) 2001-2004 Joe Hurd, distributed under the GNU GPL version 2 *)
    5.19 +(* ========================================================================= *)
    5.20 +
    5.21 +signature Portable =
    5.22 +sig
    5.23 +
    5.24 +(* ------------------------------------------------------------------------- *)
    5.25 +(* The ML implementation                                                     *)
    5.26 +(* ------------------------------------------------------------------------- *)
    5.27 +
    5.28 +val ml : string
    5.29 +
    5.30 +(* ------------------------------------------------------------------------- *)
    5.31 +(* Pointer equality using the run-time system                                *)
    5.32 +(* ------------------------------------------------------------------------- *)
    5.33 +
    5.34 +val pointerEqual : 'a * 'a -> bool
    5.35 +
    5.36 +(* ------------------------------------------------------------------------- *)
    5.37 +(* Timing function applications                                              *)
    5.38 +(* ------------------------------------------------------------------------- *)
    5.39 +
    5.40 +val time : ('a -> 'b) -> 'a -> 'b
    5.41 +
    5.42 +end
    5.43 +
    5.44 +(**** Original file: PortableIsabelle.sml ****)
    5.45 +
    5.46 +structure Metis = struct open Metis
    5.47 +(* Metis-specific ML environment *)
    5.48 +nonfix ++ -- RL mem union subset;
    5.49 +val explode = String.explode;
    5.50 +val implode = String.implode;
    5.51 +val print = TextIO.print;
    5.52 +(* ========================================================================= *)
    5.53 +(* Isabelle ML SPECIFIC FUNCTIONS                                            *)
    5.54 +(* ========================================================================= *)
    5.55 +
    5.56 +structure Portable :> Portable =
    5.57 +struct
    5.58 +
    5.59 +(* ------------------------------------------------------------------------- *)
    5.60 +(* The ML implementation.                                                    *)
    5.61 +(* ------------------------------------------------------------------------- *)
    5.62 +
    5.63 +val ml = ml_system;
    5.64 +
    5.65 +(* ------------------------------------------------------------------------- *)
    5.66 +(* Pointer equality using the run-time system.                               *)
    5.67 +(* ------------------------------------------------------------------------- *)
    5.68 +
    5.69 +val pointerEqual = pointer_eq;
    5.70 +
    5.71 +(* ------------------------------------------------------------------------- *)
    5.72 +(* Timing function applications a la Mosml.time.                             *)
    5.73 +(* ------------------------------------------------------------------------- *)
    5.74 +
    5.75 +val time = timeap;
    5.76 +
    5.77 +end
    5.78 +
    5.79 +(* ------------------------------------------------------------------------- *)
    5.80 +(* Quotations a la Moscow ML.                                                *)
    5.81 +(* ------------------------------------------------------------------------- *)
    5.82 +
    5.83 +datatype 'a frag = QUOTE of string | ANTIQUOTE of 'a;
    5.84 +end;
    5.85 +
    5.86 +(**** Original file: PP.sig ****)
    5.87 +
    5.88 +(* ========================================================================= *)
    5.89 +(* PP -- pretty-printing -- from the SML/NJ library                          *)
    5.90 +(*                                                                           *)
    5.91 +(* Modified for Moscow ML from SML/NJ Library version 0.2                    *)
    5.92 +(*                                                                           *)
    5.93 +(* COPYRIGHT (c) 1992 by AT&T Bell Laboratories.                             *)
    5.94 +(*                                                                           *)
    5.95 +(* STANDARD ML OF NEW JERSEY COPYRIGHT NOTICE, LICENSE AND DISCLAIMER.       *)
    5.96 +(*                                                                           *)
    5.97 +(* Permission to use, copy, modify, and distribute this software and its     *)
    5.98 +(* documentation for any purpose and without fee is hereby granted,          *)
    5.99 +(* provided that the above copyright notice appear in all copies and that    *)
   5.100 +(* both the copyright notice and this permission notice and warranty         *)
   5.101 +(* disclaimer appear in supporting documentation, and that the name of       *)
   5.102 +(* AT&T Bell Laboratories or any AT&T entity not be used in advertising      *)
   5.103 +(* or publicity pertaining to distribution of the software without           *)
   5.104 +(* specific, written prior permission.                                       *)
   5.105 +(*                                                                           *)
   5.106 +(* AT&T disclaims all warranties with regard to this software, including     *)
   5.107 +(* all implied warranties of merchantability and fitness.  In no event       *)
   5.108 +(* shall AT&T be liable for any special, indirect or consequential           *)
   5.109 +(* damages or any damages whatsoever resulting from loss of use, data or     *)
   5.110 +(* profits, whether in an action of contract, negligence or other            *)
   5.111 +(* tortious action, arising out of or in connection with the use or          *)
   5.112 +(* performance of this software.                                             *)
   5.113 +(* ========================================================================= *)
   5.114 +
   5.115 +signature PP =
   5.116 +sig
   5.117 +
   5.118 +  type ppstream
   5.119 +
   5.120 +  type ppconsumer =
   5.121 +       {consumer : string -> unit,
   5.122 +        linewidth : int,
   5.123 +        flush : unit -> unit}
   5.124 +
   5.125 +  datatype break_style = 
   5.126 +      CONSISTENT
   5.127 +    | INCONSISTENT
   5.128 +
   5.129 +  val mk_ppstream : ppconsumer -> ppstream
   5.130 +
   5.131 +  val dest_ppstream : ppstream -> ppconsumer
   5.132 +
   5.133 +  val add_break : ppstream -> int * int -> unit
   5.134 +
   5.135 +  val add_newline : ppstream -> unit
   5.136 +
   5.137 +  val add_string : ppstream -> string -> unit
   5.138 +
   5.139 +  val begin_block : ppstream -> break_style -> int -> unit
   5.140 +
   5.141 +  val end_block : ppstream -> unit
   5.142 +
   5.143 +  val clear_ppstream : ppstream -> unit
   5.144 +
   5.145 +  val flush_ppstream : ppstream -> unit
   5.146 +
   5.147 +  val with_pp : ppconsumer -> (ppstream -> unit) -> unit
   5.148 +
   5.149 +  val pp_to_string : int -> (ppstream -> 'a -> unit) -> 'a -> string
   5.150 +
   5.151 +end
   5.152 +
   5.153 +(* 
   5.154 +   This structure provides tools for creating customized Oppen-style
   5.155 +   pretty-printers, based on the type ppstream.  A ppstream is an
   5.156 +   output stream that contains prettyprinting commands.  The commands
   5.157 +   are placed in the stream by various function calls listed below.
   5.158 +
   5.159 +   There following primitives add commands to the stream:
   5.160 +   begin_block, end_block, add_string, add_break, and add_newline.
   5.161 +   All calls to add_string, add_break, and add_newline must happen
   5.162 +   between a pair of calls to begin_block and end_block must be
   5.163 +   properly nested dynamically.  All calls to begin_block and
   5.164 +   end_block must be properly nested (dynamically).
   5.165 +
   5.166 +   [ppconsumer] is the type of sinks for pretty-printing.  A value of 
   5.167 +   type ppconsumer is a record 
   5.168 +                 { consumer : string -> unit,
   5.169 +                   linewidth : int,
   5.170 +                   flush : unit -> unit }
   5.171 +   of a string consumer, a specified linewidth, and a flush function
   5.172 +   which is called whenever flush_ppstream is called.
   5.173 +
   5.174 +   A prettyprinter can be called outright to print a value.  In
   5.175 +   addition, a prettyprinter for a base type or nullary datatype ty
   5.176 +   can be installed in the top-level system.  Then the installed
   5.177 +   prettyprinter will be invoked automatically whenever a value of
   5.178 +   type ty is to be printed.
   5.179 +
   5.180 +   [break_style] is the type of line break styles for blocks:
   5.181 +
   5.182 +   [CONSISTENT] specifies that if any line break occurs inside the
   5.183 +   block, then all indicated line breaks occur.
   5.184 +
   5.185 +   [INCONSISTENT] specifies that breaks will be inserted to only to
   5.186 +   avoid overfull lines.
   5.187 +
   5.188 +   [mk_ppstream {consumer, linewidth, flush}] creates a new ppstream
   5.189 +   which invokes the consumer to output text, putting at most
   5.190 +   linewidth characters on each line.
   5.191 +
   5.192 +   [dest_ppstream ppstrm] extracts the linewidth, flush function, and
   5.193 +   consumer from a ppstream.
   5.194 +
   5.195 +   [add_break ppstrm (size, offset)] notifies the pretty-printer that
   5.196 +   a line break is possible at this point.  
   5.197 +   * When the current block style is CONSISTENT:
   5.198 +      ** if the entire block fits on the remainder of the line, then
   5.199 +         output size spaces; else
   5.200 +      ** increase the current indentation by the block offset;
   5.201 +         further indent every item of the block by offset, and add
   5.202 +         one newline at every add_break in the block.
   5.203 +   * When the current block style is INCONSISTENT:
   5.204 +      ** if the next component of the block fits on the remainder of
   5.205 +         the line, then output size spaces; else
   5.206 +      ** issue a newline and indent to the current indentation level
   5.207 +         plus the block offset plus the offset.
   5.208 +
   5.209 +   [add_newline ppstrm] issues a newline.
   5.210 +
   5.211 +   [add_string ppstrm str] outputs the string str to the ppstream.
   5.212 +
   5.213 +   [begin_block ppstrm style blockoffset] begins a new block and
   5.214 +   level of indentation, with the given style and block offset.
   5.215 +
   5.216 +   [end_block ppstrm] closes the current block.  
   5.217 +
   5.218 +   [clear_ppstream ppstrm] restarts the stream, without affecting the
   5.219 +   underlying consumer.
   5.220 +
   5.221 +   [flush_ppstream ppstrm] executes any remaining commands in the
   5.222 +   ppstream (that is, flushes currently accumulated output to the
   5.223 +   consumer associated with ppstrm); executes the flush function
   5.224 +   associated with the consumer; and calls clear_ppstream.
   5.225 +
   5.226 +   [with_pp consumer f] makes a new ppstream from the consumer and
   5.227 +   applies f (which can be thought of as a producer) to that
   5.228 +   ppstream, then flushed the ppstream and returns the value of f.
   5.229 +
   5.230 +   [pp_to_string linewidth printit x] constructs a new ppstream
   5.231 +   ppstrm whose consumer accumulates the output in a string s.  Then
   5.232 +   evaluates (printit ppstrm x) and finally returns the string s.
   5.233 +
   5.234 +
   5.235 +   Example 1: A simple prettyprinter for Booleans:
   5.236 +
   5.237 +       load "PP";
   5.238 +       fun ppbool pps d = 
   5.239 +           let open PP
   5.240 +           in
   5.241 +               begin_block pps INCONSISTENT 6; 
   5.242 +               add_string pps (if d then "right" else "wrong");
   5.243 +               end_block pps
   5.244 +           end;
   5.245 +
   5.246 +   Now one may define a ppstream to print to, and exercise it:
   5.247 +
   5.248 +       val ppstrm = Metis.PP.mk_ppstream {consumer  = 
   5.249 +                                    fn s => Metis.TextIO.output(Metis.TextIO.stdOut, s), 
   5.250 +                                    linewidth = 72,
   5.251 +                                    flush     = 
   5.252 +                                     fn () => Metis.TextIO.flushOut Metis.TextIO.stdOut};
   5.253 +
   5.254 +       fun ppb b = (ppbool ppstrm b; Metis.PP.flush_ppstream ppstrm);
   5.255 +
   5.256 +       - ppb false;
   5.257 +       wrong> val it = () : unit   
   5.258 +
   5.259 +   The prettyprinter may also be installed in the toplevel system;
   5.260 +   then it will be used to print all expressions of type bool
   5.261 +   subsequently computed:
   5.262 +
   5.263 +       - installPP ppbool;
   5.264 +       > val it = () : unit
   5.265 +       - 1=0;
   5.266 +       > val it = wrong : bool
   5.267 +       - 1=1;
   5.268 +       > val it = right : bool
   5.269 +
   5.270 +   See library Meta for a description of installPP.
   5.271 +
   5.272 +
   5.273 +   Example 2: Prettyprinting simple expressions (examples/pretty/Metis.ppexpr.sml):
   5.274 +
   5.275 +       datatype expr = 
   5.276 +           Cst of int 
   5.277 +         | Neg of expr
   5.278 +         | Plus of expr * expr
   5.279 +
   5.280 +       fun ppexpr pps e0 = 
   5.281 +           let open PP
   5.282 +               fun ppe (Cst i)        = add_string pps (Metis.Int.toString i)
   5.283 +                 | ppe (Neg e)        = (add_string pps "~"; ppe e)
   5.284 +                 | ppe (Plus(e1, e2)) = (begin_block pps CONSISTENT 0;
   5.285 +                                         add_string pps "(";
   5.286 +                                         ppe e1; 
   5.287 +                                         add_string pps " + ";
   5.288 +                                         add_break pps (0, 1);
   5.289 +                                         ppe e2; 
   5.290 +                                         add_string pps ")";
   5.291 +                                         end_block pps)
   5.292 +           in
   5.293 +               begin_block pps INCONSISTENT 0; 
   5.294 +               ppe e0;
   5.295 +               end_block pps
   5.296 +           end
   5.297 +
   5.298 +       val _ = installPP ppexpr;
   5.299 +
   5.300 +       (* Some example values: *)
   5.301 +
   5.302 +       val e1 = Cst 1;
   5.303 +       val e2 = Cst 2;
   5.304 +       val e3 = Plus(e1, Neg e2);
   5.305 +       val e4 = Plus(Neg e3, e3);
   5.306 +       val e5 = Plus(Neg e4, e4);
   5.307 +       val e6 = Plus(e5, e5);
   5.308 +       val e7 = Plus(e6, e6);
   5.309 +       val e8 = 
   5.310 +           Plus(e3, Plus(e3, Plus(e3, Plus(e3, Plus(e3, Plus(e3, e7))))));
   5.311 +*)
   5.312 +
   5.313 +(**** Original file: PP.sml ****)
   5.314 +
   5.315 +structure Metis = struct open Metis
   5.316 +(* Metis-specific ML environment *)
   5.317 +nonfix ++ -- RL mem union subset;
   5.318 +val explode = String.explode;
   5.319 +val implode = String.implode;
   5.320 +val print = TextIO.print;
   5.321 +(* ========================================================================= *)
   5.322 +(* PP -- pretty-printing -- from the SML/NJ library                          *)
   5.323 +(*                                                                           *)
   5.324 +(* Modified for Moscow ML from SML/NJ Library version 0.2                    *)
   5.325 +(*                                                                           *)
   5.326 +(* COPYRIGHT (c) 1992 by AT&T Bell Laboratories.                             *)
   5.327 +(*                                                                           *)
   5.328 +(* STANDARD ML OF NEW JERSEY COPYRIGHT NOTICE, LICENSE AND DISCLAIMER.       *)
   5.329 +(*                                                                           *)
   5.330 +(* Permission to use, copy, modify, and distribute this software and its     *)
   5.331 +(* documentation for any purpose and without fee is hereby granted,          *)
   5.332 +(* provided that the above copyright notice appear in all copies and that    *)
   5.333 +(* both the copyright notice and this permission notice and warranty         *)
   5.334 +(* disclaimer appear in supporting documentation, and that the name of       *)
   5.335 +(* AT&T Bell Laboratories or any AT&T entity not be used in advertising      *)
   5.336 +(* or publicity pertaining to distribution of the software without           *)
   5.337 +(* specific, written prior permission.                                       *)
   5.338 +(*                                                                           *)
   5.339 +(* AT&T disclaims all warranties with regard to this software, including     *)
   5.340 +(* all implied warranties of merchantability and fitness.  In no event       *)
   5.341 +(* shall AT&T be liable for any special, indirect or consequential           *)
   5.342 +(* damages or any damages whatsoever resulting from loss of use, data or     *)
   5.343 +(* profits, whether in an action of contract, negligence or other            *)
   5.344 +(* tortious action, arising out of or in connection with the use or          *)
   5.345 +(* performance of this software.                                             *)
   5.346 +(* ========================================================================= *)
   5.347 +
   5.348 +structure PP :> PP =
   5.349 +struct
   5.350 +
   5.351 +open Array 
   5.352 +infix 9 sub
   5.353 +
   5.354 +(* the queue library, formerly in unit Ppqueue *)
   5.355 +
   5.356 +datatype Qend = Qback | Qfront
   5.357 +
   5.358 +exception QUEUE_FULL
   5.359 +exception QUEUE_EMPTY
   5.360 +exception REQUESTED_QUEUE_SIZE_TOO_SMALL
   5.361 +
   5.362 +local 
   5.363 +    fun ++ i n = (i + 1) mod n
   5.364 +    fun -- i n = (i - 1) mod n
   5.365 +in
   5.366 +
   5.367 +abstype 'a queue = QUEUE of {elems: 'a array, (* the contents *)
   5.368 +                             front: int ref,
   5.369 +                             back: int ref,
   5.370 +                             size: int}  (* fixed size of element array *)
   5.371 +with
   5.372 +
   5.373 +  fun is_empty (QUEUE{front=ref ~1, back=ref ~1,...}) = true
   5.374 +    | is_empty _ = false
   5.375 +
   5.376 +  fun mk_queue n init_val =
   5.377 +      if (n < 2)
   5.378 +      then raise REQUESTED_QUEUE_SIZE_TOO_SMALL
   5.379 +      else QUEUE{elems=array(n, init_val), front=ref ~1, back=ref ~1, size=n}
   5.380 +
   5.381 +  fun clear_queue (QUEUE{front,back,...}) = (front := ~1; back := ~1)
   5.382 +
   5.383 +  fun queue_at Qfront (QUEUE{elems,front,...}) = elems sub !front
   5.384 +    | queue_at Qback (QUEUE{elems,back,...}) = elems sub !back
   5.385 +
   5.386 +  fun en_queue Qfront item (Q as QUEUE{elems,front,back,size}) =
   5.387 +        if (is_empty Q)
   5.388 +        then (front := 0; back := 0;
   5.389 +              update(elems,0,item))
   5.390 +        else let val i = --(!front) size
   5.391 +             in  if (i = !back)
   5.392 +                 then raise QUEUE_FULL
   5.393 +                 else (update(elems,i,item); front := i)
   5.394 +             end
   5.395 +    | en_queue Qback item (Q as QUEUE{elems,front,back,size}) =
   5.396 +        if (is_empty Q)
   5.397 +        then (front := 0; back := 0;
   5.398 +              update(elems,0,item))
   5.399 +        else let val i = ++(!back) size
   5.400 +             in  if (i = !front)
   5.401 +                 then raise QUEUE_FULL
   5.402 +                 else (update(elems,i,item); back := i)
   5.403 +             end
   5.404 +
   5.405 +  fun de_queue Qfront (Q as QUEUE{front,back,size,...}) =
   5.406 +        if (!front = !back) (* unitary queue *)
   5.407 +        then clear_queue Q
   5.408 +        else front := ++(!front) size
   5.409 +    | de_queue Qback (Q as QUEUE{front,back,size,...}) =
   5.410 +        if (!front = !back)
   5.411 +        then clear_queue Q
   5.412 +        else back := --(!back) size
   5.413 +
   5.414 +end (* abstype queue *)
   5.415 +end (* local   *)
   5.416 +
   5.417 +
   5.418 +val magic: 'a -> 'a = fn x => x
   5.419 +
   5.420 +(* exception PP_FAIL of string *)
   5.421 +
   5.422 +datatype break_style = CONSISTENT | INCONSISTENT
   5.423 +
   5.424 +datatype break_info
   5.425 +  = FITS
   5.426 +  | PACK_ONTO_LINE of int
   5.427 +  | ONE_PER_LINE of int
   5.428 +
   5.429 +(* Some global values *)
   5.430 +val INFINITY = 999999
   5.431 +
   5.432 +abstype indent_stack = Istack of break_info list ref
   5.433 +with
   5.434 +  fun mk_indent_stack() = Istack (ref([]:break_info list))
   5.435 +  fun clear_indent_stack (Istack stk) = (stk := ([]:break_info list))
   5.436 +  fun top (Istack stk) =
   5.437 +      case !stk
   5.438 +        of nil => raise Fail "PP-error: top: badly formed block"
   5.439 +	 | x::_ => x
   5.440 +  fun push (x,(Istack stk)) = stk := x::(!stk)
   5.441 +  fun pop (Istack stk) =
   5.442 +      case !stk
   5.443 +        of nil => raise Fail "PP-error: pop: badly formed block"
   5.444 +	 | _::rest => stk := rest
   5.445 +end
   5.446 +
   5.447 +(* The delim_stack is used to compute the size of blocks. It is
   5.448 +   a stack of indices into the token buffer. The indices only point to
   5.449 +   BBs, Es, and BRs. We push BBs and Es onto the stack until a BR
   5.450 +   is encountered. Then we compute sizes and pop. When we encounter
   5.451 +   a BR in the middle of a block, we compute the Distance_to_next_break
   5.452 +   of the previous BR in the block, if there was one.
   5.453 +
   5.454 +   We need to be able to delete from the bottom of the delim_stack, so
   5.455 +   we use a queue, treated with a stack discipline, i.e., we only add
   5.456 +   items at the head of the queue, but can delete from the front or
   5.457 +   back of the queue.
   5.458 +*)
   5.459 +abstype delim_stack = Dstack of int queue
   5.460 +with
   5.461 +  fun new_delim_stack i = Dstack(mk_queue i ~1)
   5.462 +  fun reset_delim_stack (Dstack q) = clear_queue q
   5.463 +
   5.464 +  fun pop_delim_stack (Dstack d) = de_queue Qfront d
   5.465 +  fun pop_bottom_delim_stack (Dstack d) = de_queue Qback d
   5.466 +
   5.467 +  fun push_delim_stack(i,Dstack d) = en_queue Qfront i d
   5.468 +  fun top_delim_stack (Dstack d) = queue_at Qfront d
   5.469 +  fun bottom_delim_stack (Dstack d) = queue_at Qback d
   5.470 +  fun delim_stack_is_empty (Dstack d) = is_empty d
   5.471 +end
   5.472 +
   5.473 +
   5.474 +type block_info = { Block_size : int ref,
   5.475 +                    Block_offset : int,
   5.476 +                    How_to_indent : break_style }
   5.477 +
   5.478 +
   5.479 +(* Distance_to_next_break includes Number_of_blanks. Break_offset is
   5.480 +   a local offset for the break. BB represents a sequence of contiguous
   5.481 +   Begins. E represents a sequence of contiguous Ends.
   5.482 +*)
   5.483 +datatype pp_token
   5.484 +  = S of  {String : string, Length : int}
   5.485 +  | BB of {Pblocks : block_info list ref,   (* Processed   *)
   5.486 +           Ublocks : block_info list ref}  (* Unprocessed *)
   5.487 +  | E of  {Pend : int ref, Uend : int ref}
   5.488 +  | BR of {Distance_to_next_break : int ref,
   5.489 +           Number_of_blanks : int,
   5.490 +           Break_offset : int}
   5.491 +
   5.492 +
   5.493 +(* The initial values in the token buffer *)
   5.494 +val initial_token_value = S{String = "", Length = 0}
   5.495 +
   5.496 +(* type ppstream = General.ppstream; *)
   5.497 +datatype ppstream_ =
   5.498 +  PPS of
   5.499 +     {consumer : string -> unit,
   5.500 +      linewidth : int,
   5.501 +      flush : unit -> unit,
   5.502 +      the_token_buffer : pp_token array,
   5.503 +      the_delim_stack : delim_stack,
   5.504 +      the_indent_stack : indent_stack,
   5.505 +      ++ : int ref -> unit,    (* increment circular buffer index *)
   5.506 +      space_left : int ref,    (* remaining columns on page *)
   5.507 +      left_index : int ref,    (* insertion index *)
   5.508 +      right_index : int ref,   (* output index *)
   5.509 +      left_sum : int ref,      (* size of strings and spaces inserted *)
   5.510 +      right_sum : int ref}     (* size of strings and spaces printed *)
   5.511 +
   5.512 +type ppstream = ppstream_
   5.513 +
   5.514 +type ppconsumer = {consumer : string -> unit,
   5.515 +		   linewidth : int,
   5.516 +		   flush : unit -> unit}
   5.517 +
   5.518 +fun mk_ppstream {consumer,linewidth,flush} =
   5.519 +    if (linewidth<5)
   5.520 +    then raise Fail "PP-error: linewidth too_small"
   5.521 +    else let val buf_size = 3*linewidth
   5.522 +          in magic(
   5.523 +             PPS{consumer = consumer,
   5.524 +		 linewidth = linewidth,
   5.525 +		 flush = flush,
   5.526 +		 the_token_buffer = array(buf_size, initial_token_value),
   5.527 +		 the_delim_stack = new_delim_stack buf_size,
   5.528 +		 the_indent_stack = mk_indent_stack (),
   5.529 +		 ++ = fn i => i := ((!i + 1) mod buf_size),
   5.530 +		 space_left = ref linewidth,
   5.531 +		 left_index = ref 0, right_index = ref 0,
   5.532 +		 left_sum = ref 0, right_sum = ref 0}
   5.533 +                 ) : ppstream
   5.534 +	 end
   5.535 +
   5.536 +fun dest_ppstream(pps : ppstream) =
   5.537 +  let val PPS{consumer,linewidth,flush, ...} = magic pps
   5.538 +  in {consumer=consumer,linewidth=linewidth,flush=flush} end
   5.539 +
   5.540 +local
   5.541 +  val space = " "
   5.542 +  fun mk_space (0,s) = String.concat s
   5.543 +    | mk_space (n,s) = mk_space((n-1), (space::s))
   5.544 +  val space_table = Vector.tabulate(100, fn i => mk_space(i,[]))
   5.545 +  fun nspaces n = Vector.sub(space_table, n)
   5.546 +      handle General.Subscript =>
   5.547 +	if n < 0
   5.548 +	then ""
   5.549 +	else let val n2 = n div 2
   5.550 +		 val n2_spaces = nspaces n2
   5.551 +		 val extra = if (n = (2*n2)) then "" else space
   5.552 +              in String.concat [n2_spaces, n2_spaces, extra]
   5.553 +	     end
   5.554 +in
   5.555 +  fun cr_indent (ofn, i) = ofn ("\n"^(nspaces i))
   5.556 +  fun indent (ofn,i) = ofn (nspaces i)
   5.557 +end
   5.558 +
   5.559 +
   5.560 +(* Print a the first member of a contiguous sequence of Begins. If there
   5.561 +   are "processed" Begins, then take the first off the list. If there are
   5.562 +   no processed Begins, take the last member off the "unprocessed" list.
   5.563 +   This works because the unprocessed list is treated as a stack, the
   5.564 +   processed list as a FIFO queue. How can an item on the unprocessed list
   5.565 +   be printable? Because of what goes on in add_string. See there for details.
   5.566 +*)
   5.567 +
   5.568 +fun print_BB (_,{Pblocks = ref [], Ublocks = ref []}) =
   5.569 +             raise Fail "PP-error: print_BB"
   5.570 +  | print_BB (PPS{the_indent_stack,linewidth,space_left=ref sp_left,...},
   5.571 +             {Pblocks as ref({How_to_indent=CONSISTENT,Block_size,
   5.572 +                              Block_offset}::rst),
   5.573 +              Ublocks=ref[]}) =
   5.574 +       (push ((if (!Block_size > sp_left)
   5.575 +               then ONE_PER_LINE (linewidth - (sp_left - Block_offset))
   5.576 +               else FITS),
   5.577 +	      the_indent_stack);
   5.578 +        Pblocks := rst)
   5.579 +  | print_BB(PPS{the_indent_stack,linewidth,space_left=ref sp_left,...},
   5.580 +             {Pblocks as ref({Block_size,Block_offset,...}::rst),Ublocks=ref[]}) =
   5.581 +       (push ((if (!Block_size > sp_left)
   5.582 +               then PACK_ONTO_LINE (linewidth - (sp_left - Block_offset))
   5.583 +               else FITS),
   5.584 +	      the_indent_stack);
   5.585 +        Pblocks := rst)
   5.586 +  | print_BB (PPS{the_indent_stack, linewidth, space_left=ref sp_left,...},
   5.587 +              {Ublocks,...}) =
   5.588 +      let fun pr_end_Ublock [{How_to_indent=CONSISTENT,Block_size,Block_offset}] l =
   5.589 +		(push ((if (!Block_size > sp_left)
   5.590 +			then ONE_PER_LINE (linewidth - (sp_left - Block_offset))
   5.591 +			else FITS),
   5.592 +		       the_indent_stack);
   5.593 +                 List.rev l)
   5.594 +	    | pr_end_Ublock [{Block_size,Block_offset,...}] l =
   5.595 +		(push ((if (!Block_size > sp_left)
   5.596 +			then PACK_ONTO_LINE (linewidth - (sp_left - Block_offset))
   5.597 +			else FITS),
   5.598 +		       the_indent_stack);
   5.599 +                 List.rev l)
   5.600 +	    | pr_end_Ublock (a::rst) l = pr_end_Ublock rst (a::l)
   5.601 +            | pr_end_Ublock _ _ =
   5.602 +                raise Fail "PP-error: print_BB: internal error"
   5.603 +       in Ublocks := pr_end_Ublock(!Ublocks) []
   5.604 +      end
   5.605 +
   5.606 +
   5.607 +(* Uend should always be 0 when print_E is called. *)
   5.608 +fun print_E (_,{Pend = ref 0, Uend = ref 0}) =
   5.609 +      raise Fail "PP-error: print_E"
   5.610 +  | print_E (istack,{Pend, ...}) =
   5.611 +      let fun pop_n_times 0 = ()
   5.612 +	    | pop_n_times n = (pop istack; pop_n_times(n-1))
   5.613 +       in pop_n_times(!Pend); Pend := 0
   5.614 +      end
   5.615 +
   5.616 +
   5.617 +(* "cursor" is how many spaces across the page we are. *)
   5.618 +
   5.619 +fun print_token(PPS{consumer,space_left,...}, S{String,Length}) =
   5.620 +      (consumer String;
   5.621 +       space_left := (!space_left) - Length)
   5.622 +  | print_token(ppstrm,BB b) = print_BB(ppstrm,b)
   5.623 +  | print_token(PPS{the_indent_stack,...},E e) =
   5.624 +      print_E (the_indent_stack,e)
   5.625 +  | print_token (PPS{the_indent_stack,space_left,consumer,linewidth,...},
   5.626 +                 BR{Distance_to_next_break,Number_of_blanks,Break_offset}) =
   5.627 +     (case (top the_indent_stack)
   5.628 +        of FITS =>
   5.629 +	     (space_left := (!space_left) - Number_of_blanks;
   5.630 +              indent (consumer,Number_of_blanks))
   5.631 +         | (ONE_PER_LINE cursor) =>
   5.632 +             let val new_cursor = cursor + Break_offset
   5.633 +              in space_left := linewidth - new_cursor;
   5.634 +                 cr_indent (consumer,new_cursor)
   5.635 +	     end
   5.636 +         | (PACK_ONTO_LINE cursor) =>
   5.637 +	     if (!Distance_to_next_break > (!space_left))
   5.638 +	     then let val new_cursor = cursor + Break_offset
   5.639 +		   in space_left := linewidth - new_cursor;
   5.640 +		      cr_indent(consumer,new_cursor)
   5.641 +		  end
   5.642 +	     else (space_left := !space_left - Number_of_blanks;
   5.643 +		   indent (consumer,Number_of_blanks)))
   5.644 +
   5.645 +
   5.646 +fun clear_ppstream(pps : ppstream) =
   5.647 +    let val PPS{the_token_buffer, the_delim_stack,
   5.648 +                the_indent_stack,left_sum, right_sum,
   5.649 +                left_index, right_index,space_left,linewidth,...}
   5.650 +              = magic pps
   5.651 +        val buf_size = 3*linewidth
   5.652 +	fun set i =
   5.653 +	    if (i = buf_size)
   5.654 +	    then ()
   5.655 +	    else (update(the_token_buffer,i,initial_token_value);
   5.656 +		  set (i+1))
   5.657 +     in set 0;
   5.658 +	clear_indent_stack the_indent_stack;
   5.659 +	reset_delim_stack the_delim_stack;
   5.660 +	left_sum := 0; right_sum := 0;
   5.661 +	left_index := 0; right_index := 0;
   5.662 +	space_left := linewidth
   5.663 +    end
   5.664 +
   5.665 +
   5.666 +(* Move insertion head to right unless adding a BB and already at a BB,
   5.667 +   or unless adding an E and already at an E.
   5.668 +*)
   5.669 +fun BB_inc_right_index(PPS{the_token_buffer, right_index, ++,...})=
   5.670 +    case (the_token_buffer sub (!right_index))
   5.671 +      of (BB _) => ()
   5.672 +       | _ => ++right_index
   5.673 +
   5.674 +fun E_inc_right_index(PPS{the_token_buffer,right_index, ++,...})=
   5.675 +    case (the_token_buffer sub (!right_index))
   5.676 +      of (E _) => ()
   5.677 +       | _ => ++right_index
   5.678 +
   5.679 +
   5.680 +fun pointers_coincide(PPS{left_index,right_index,the_token_buffer,...}) =
   5.681 +    (!left_index = !right_index) andalso
   5.682 +    (case (the_token_buffer sub (!left_index))
   5.683 +       of (BB {Pblocks = ref [], Ublocks = ref []}) => true
   5.684 +	| (BB _) => false
   5.685 +	| (E {Pend = ref 0, Uend = ref 0}) => true
   5.686 +	| (E _) => false
   5.687 +	| _ => true)
   5.688 +
   5.689 +fun advance_left (ppstrm as PPS{consumer,left_index,left_sum,
   5.690 +                                the_token_buffer,++,...},
   5.691 +                  instr) =
   5.692 +    let val NEG = ~1
   5.693 +	val POS = 0
   5.694 +	fun inc_left_sum (BR{Number_of_blanks, ...}) =
   5.695 +		 left_sum := (!left_sum) + Number_of_blanks
   5.696 +	  | inc_left_sum (S{Length, ...}) = left_sum := (!left_sum) + Length
   5.697 +	  | inc_left_sum _ = ()
   5.698 +
   5.699 +	fun last_size [{Block_size, ...}:block_info] = !Block_size
   5.700 +	  | last_size (_::rst) = last_size rst
   5.701 +          | last_size _ = raise Fail "PP-error: last_size: internal error"
   5.702 +	fun token_size (S{Length, ...}) = Length
   5.703 +	  | token_size (BB b) =
   5.704 +	     (case b
   5.705 +                of {Pblocks = ref [], Ublocks = ref []} =>
   5.706 +                     raise Fail "PP-error: BB_size"
   5.707 +	         | {Pblocks as ref(_::_),Ublocks=ref[]} => POS
   5.708 +		 | {Ublocks, ...} => last_size (!Ublocks))
   5.709 +	  | token_size (E{Pend = ref 0, Uend = ref 0}) =
   5.710 +              raise Fail "PP-error: token_size.E"
   5.711 +	  | token_size (E{Pend = ref 0, ...}) = NEG
   5.712 +	  | token_size (E _) = POS
   5.713 +	  | token_size (BR {Distance_to_next_break, ...}) = !Distance_to_next_break
   5.714 +	fun loop (instr) =
   5.715 +	    if (token_size instr < 0)  (* synchronization point; cannot advance *)
   5.716 +	    then ()
   5.717 +	    else (print_token(ppstrm,instr);
   5.718 +		  inc_left_sum instr;
   5.719 +		  if (pointers_coincide ppstrm)
   5.720 +		  then ()
   5.721 +		  else (* increment left index *)
   5.722 +
   5.723 +    (* When this is evaluated, we know that the left_index has not yet
   5.724 +       caught up to the right_index. If we are at a BB or an E, we can
   5.725 +       increment left_index if there is no work to be done, i.e., all Begins
   5.726 +       or Ends have been dealt with. Also, we should do some housekeeping and
   5.727 +       clear the buffer at left_index, otherwise we can get errors when
   5.728 +       left_index catches up to right_index and we reset the indices to 0.
   5.729 +       (We might find ourselves adding a BB to an "old" BB, with the result
   5.730 +       that the index is not pushed onto the delim_stack. This can lead to
   5.731 +       mangled output.)
   5.732 +    *)
   5.733 +		       (case (the_token_buffer sub (!left_index))
   5.734 +			  of (BB {Pblocks = ref [], Ublocks = ref []}) =>
   5.735 +			       (update(the_token_buffer,!left_index,
   5.736 +				       initial_token_value);
   5.737 +				++left_index)
   5.738 +			   | (BB _) => ()
   5.739 +			   | (E {Pend = ref 0, Uend = ref 0}) =>
   5.740 +			       (update(the_token_buffer,!left_index,
   5.741 +				       initial_token_value);
   5.742 +				++left_index)
   5.743 +			   | (E _) => ()
   5.744 +			   | _ => ++left_index;
   5.745 +			loop (the_token_buffer sub (!left_index))))
   5.746 +     in loop instr
   5.747 +    end
   5.748 +
   5.749 +
   5.750 +fun begin_block (pps : ppstream) style offset =
   5.751 +  let val ppstrm = magic pps : ppstream_
   5.752 +      val PPS{the_token_buffer, the_delim_stack,left_index,
   5.753 +              left_sum, right_index, right_sum,...}
   5.754 +            = ppstrm
   5.755 +  in
   5.756 +   (if (delim_stack_is_empty the_delim_stack)
   5.757 +    then (left_index := 0;
   5.758 +	  left_sum := 1;
   5.759 +	  right_index := 0;
   5.760 +	  right_sum := 1)
   5.761 +    else BB_inc_right_index ppstrm;
   5.762 +    case (the_token_buffer sub (!right_index))
   5.763 +      of (BB {Ublocks, ...}) =>
   5.764 +	   Ublocks := {Block_size = ref (~(!right_sum)),
   5.765 +		       Block_offset = offset,
   5.766 +		       How_to_indent = style}::(!Ublocks)
   5.767 +       | _ => (update(the_token_buffer, !right_index,
   5.768 +		      BB{Pblocks = ref [],
   5.769 +			 Ublocks = ref [{Block_size = ref (~(!right_sum)),
   5.770 +					 Block_offset = offset,
   5.771 +					 How_to_indent = style}]});
   5.772 +	       push_delim_stack (!right_index, the_delim_stack)))
   5.773 +  end
   5.774 +
   5.775 +fun end_block(pps : ppstream) =
   5.776 +  let val ppstrm = magic pps : ppstream_
   5.777 +      val PPS{the_token_buffer,the_delim_stack,right_index,...}
   5.778 +            = ppstrm
   5.779 +  in
   5.780 +    if (delim_stack_is_empty the_delim_stack)
   5.781 +    then print_token(ppstrm,(E{Pend = ref 1, Uend = ref 0}))
   5.782 +    else (E_inc_right_index ppstrm;
   5.783 +	  case (the_token_buffer sub (!right_index))
   5.784 +            of (E{Uend, ...}) => Uend := !Uend + 1
   5.785 +	     | _ => (update(the_token_buffer,!right_index,
   5.786 +			    E{Uend = ref 1, Pend = ref 0});
   5.787 +		     push_delim_stack (!right_index, the_delim_stack)))
   5.788 +  end
   5.789 +
   5.790 +local
   5.791 +  fun check_delim_stack(PPS{the_token_buffer,the_delim_stack,right_sum,...}) =
   5.792 +      let fun check k =
   5.793 +	      if (delim_stack_is_empty the_delim_stack)
   5.794 +	      then ()
   5.795 +	      else case(the_token_buffer sub (top_delim_stack the_delim_stack))
   5.796 +		     of (BB{Ublocks as ref ((b as {Block_size, ...})::rst),
   5.797 +			    Pblocks}) =>
   5.798 +			   if (k>0)
   5.799 +			   then (Block_size := !right_sum + !Block_size;
   5.800 +				 Pblocks := b :: (!Pblocks);
   5.801 +				 Ublocks := rst;
   5.802 +				 if (List.length rst = 0)
   5.803 +				 then pop_delim_stack the_delim_stack
   5.804 +				 else ();
   5.805 +				 check(k-1))
   5.806 +			   else ()
   5.807 +		      | (E{Pend,Uend}) =>
   5.808 +			   (Pend := (!Pend) + (!Uend);
   5.809 +			    Uend := 0;
   5.810 +			    pop_delim_stack the_delim_stack;
   5.811 +			    check(k + !Pend))
   5.812 +		      | (BR{Distance_to_next_break, ...}) =>
   5.813 +			   (Distance_to_next_break :=
   5.814 +			      !right_sum + !Distance_to_next_break;
   5.815 +			    pop_delim_stack the_delim_stack;
   5.816 +			    if (k>0)
   5.817 +			    then check k
   5.818 +			    else ())
   5.819 +                      | _ => raise Fail "PP-error: check_delim_stack.catchall"
   5.820 +       in check 0
   5.821 +      end
   5.822 +in
   5.823 +
   5.824 +  fun add_break (pps : ppstream) (n, break_offset) =
   5.825 +    let val ppstrm = magic pps : ppstream_
   5.826 +        val PPS{the_token_buffer,the_delim_stack,left_index,
   5.827 +                right_index,left_sum,right_sum, ++, ...}
   5.828 +              = ppstrm
   5.829 +    in
   5.830 +      (if (delim_stack_is_empty the_delim_stack)
   5.831 +       then (left_index := 0; right_index := 0;
   5.832 +	     left_sum := 1;   right_sum := 1)
   5.833 +       else ++right_index;
   5.834 +       update(the_token_buffer, !right_index,
   5.835 +	      BR{Distance_to_next_break = ref (~(!right_sum)),
   5.836 +		 Number_of_blanks = n,
   5.837 +		 Break_offset = break_offset});
   5.838 +       check_delim_stack ppstrm;
   5.839 +       right_sum := (!right_sum) + n;
   5.840 +       push_delim_stack (!right_index,the_delim_stack))
   5.841 +    end
   5.842 +
   5.843 +  fun flush_ppstream0(pps : ppstream) =
   5.844 +    let val ppstrm = magic pps : ppstream_
   5.845 +        val PPS{the_delim_stack,the_token_buffer, flush, left_index,...}
   5.846 +              = ppstrm
   5.847 +    in
   5.848 +      (if (delim_stack_is_empty the_delim_stack)
   5.849 +       then ()
   5.850 +       else (check_delim_stack ppstrm;
   5.851 +	     advance_left(ppstrm, the_token_buffer sub (!left_index)));
   5.852 +       flush())
   5.853 +    end
   5.854 +
   5.855 +end (* local *)
   5.856 +
   5.857 +
   5.858 +fun flush_ppstream ppstrm =
   5.859 +    (flush_ppstream0 ppstrm;
   5.860 +     clear_ppstream ppstrm)
   5.861 +
   5.862 +fun add_string (pps : ppstream) s =
   5.863 +    let val ppstrm = magic pps : ppstream_
   5.864 +        val PPS{the_token_buffer,the_delim_stack,consumer,
   5.865 +                right_index,right_sum,left_sum,
   5.866 +                left_index,space_left,++,...}
   5.867 +              = ppstrm
   5.868 +        fun fnl [{Block_size, ...}:block_info] = Block_size := INFINITY
   5.869 +	  | fnl (_::rst) = fnl rst
   5.870 +          | fnl _ = raise Fail "PP-error: fnl: internal error"
   5.871 +
   5.872 +	fun set(dstack,BB{Ublocks as ref[{Block_size,...}:block_info],...}) =
   5.873 +	      (pop_bottom_delim_stack dstack;
   5.874 +	       Block_size := INFINITY)
   5.875 +	  | set (_,BB {Ublocks = ref(_::rst), ...}) = fnl rst
   5.876 +	  | set (dstack, E{Pend,Uend}) =
   5.877 +	      (Pend := (!Pend) + (!Uend);
   5.878 +	       Uend := 0;
   5.879 +	       pop_bottom_delim_stack dstack)
   5.880 +	  | set (dstack,BR{Distance_to_next_break,...}) =
   5.881 +	      (pop_bottom_delim_stack dstack;
   5.882 +	       Distance_to_next_break := INFINITY)
   5.883 +          | set _ = raise (Fail "PP-error: add_string.set")
   5.884 +
   5.885 +	fun check_stream () =
   5.886 +	    if ((!right_sum - !left_sum) > !space_left)
   5.887 +	    then if (delim_stack_is_empty the_delim_stack)
   5.888 +		 then ()
   5.889 +		 else let val i = bottom_delim_stack the_delim_stack
   5.890 +		       in if (!left_index = i)
   5.891 +			  then set (the_delim_stack, the_token_buffer sub i)
   5.892 +			  else ();
   5.893 +			  advance_left(ppstrm,
   5.894 +                                       the_token_buffer sub (!left_index));
   5.895 +		          if (pointers_coincide ppstrm)
   5.896 +		          then ()
   5.897 +		          else check_stream ()
   5.898 +		      end
   5.899 +	    else ()
   5.900 +
   5.901 +	val slen = String.size s
   5.902 +	val S_token = S{String = s, Length = slen}
   5.903 +
   5.904 +    in if (delim_stack_is_empty the_delim_stack)
   5.905 +       then print_token(ppstrm,S_token)
   5.906 +       else (++right_index;
   5.907 +             update(the_token_buffer, !right_index, S_token);
   5.908 +             right_sum := (!right_sum)+slen;
   5.909 +             check_stream ())
   5.910 +   end
   5.911 +
   5.912 +
   5.913 +(* Derived form. The +2 is for peace of mind *)
   5.914 +fun add_newline (pps : ppstream) =
   5.915 +  let val PPS{linewidth, ...} = magic pps
   5.916 +  in add_break pps (linewidth+2,0) end
   5.917 +
   5.918 +(* Derived form. Builds a ppstream, sends pretty printing commands called in
   5.919 +   f to the ppstream, then flushes ppstream.
   5.920 +*)
   5.921 +
   5.922 +fun with_pp ppconsumer ppfn =
   5.923 +   let val ppstrm = mk_ppstream ppconsumer
   5.924 +    in ppfn ppstrm;
   5.925 +       flush_ppstream0 ppstrm
   5.926 +   end
   5.927 +   handle Fail msg =>
   5.928 +     (TextIO.print (">>>> Pretty-printer failure: " ^ msg ^ "\n"))
   5.929 +
   5.930 +fun pp_to_string linewidth ppfn ob =
   5.931 +    let val l = ref ([]:string list)
   5.932 +	fun attach s = l := (s::(!l))
   5.933 +     in with_pp {consumer = attach, linewidth=linewidth, flush = fn()=>()}
   5.934 +		(fn ppstrm =>  ppfn ppstrm ob);
   5.935 +	String.concat(List.rev(!l))
   5.936 +    end
   5.937 +end
   5.938 +end;
   5.939 +
   5.940 +(**** Original file: Random.sig ****)
   5.941 +
   5.942 +(* Random -- random number generator *)
   5.943 +
   5.944 +signature Random =
   5.945 +sig
   5.946 +
   5.947 +type generator
   5.948 +
   5.949 +val newgenseed : real -> generator
   5.950 +val newgen     : unit -> generator
   5.951 +val random     : generator -> real
   5.952 +val randomlist : int * generator -> real list
   5.953 +val range      : int * int -> generator -> int
   5.954 +val rangelist  : int * int -> int * generator -> int list
   5.955 +
   5.956 +end
   5.957 +
   5.958 +(* 
   5.959 +   [generator] is the type of random number generators, here the
   5.960 +   linear congruential generators from Paulson 1991, 1996.
   5.961 +
   5.962 +   [newgenseed seed] returns a random number generator with the given seed.
   5.963 +
   5.964 +   [newgen ()] returns a random number generator, taking the seed from
   5.965 +   the system clock.
   5.966 +
   5.967 +   [random gen] returns a random number in the interval [0..1).
   5.968 +
   5.969 +   [randomlist (n, gen)] returns a list of n random numbers in the
   5.970 +   interval [0,1).
   5.971 +
   5.972 +   [range (min, max) gen] returns an integral random number in the
   5.973 +   range [min, max).  Raises Fail if min > max.
   5.974 +
   5.975 +   [rangelist (min, max) (n, gen)] returns a list of n integral random
   5.976 +   numbers in the range [min, max).  Raises Fail if min > max.  
   5.977 +*)
   5.978 +
   5.979 +(**** Original file: Random.sml ****)
   5.980 +
   5.981 +structure Metis = struct open Metis
   5.982 +(* Metis-specific ML environment *)
   5.983 +nonfix ++ -- RL mem union subset;
   5.984 +val explode = String.explode;
   5.985 +val implode = String.implode;
   5.986 +val print = TextIO.print;
   5.987 +(* Random -- Moscow ML library 1995-04-23, 1999-02-24 *)
   5.988 +
   5.989 +structure Random :> Random =
   5.990 +struct
   5.991 +
   5.992 +type generator = {seedref : real ref}
   5.993 +
   5.994 +(* Generating random numbers.  Paulson, page 96 *)
   5.995 +
   5.996 +val a = 16807.0 
   5.997 +val m = 2147483647.0 
   5.998 +fun nextrand seed = 
   5.999 +    let val t = a*seed 
  5.1000 +    in t - m * real(floor(t/m)) end
  5.1001 +
  5.1002 +fun newgenseed seed =
  5.1003 +    {seedref = ref (nextrand seed)};
  5.1004 +
  5.1005 +fun newgen () = newgenseed (Time.toReal (Time.now ()));
  5.1006 +
  5.1007 +fun random {seedref as ref seed} = 
  5.1008 +    (seedref := nextrand seed; seed / m);
  5.1009 +
  5.1010 +fun randomlist (n, {seedref as ref seed0}) = 
  5.1011 +    let fun h 0 seed res = (seedref := seed; res)
  5.1012 +	  | h i seed res = h (i-1) (nextrand seed) (seed / m :: res)
  5.1013 +    in h n seed0 [] end;
  5.1014 +
  5.1015 +fun range (min, max) = 
  5.1016 +    if min > max then raise Fail "Random.range: empty range" 
  5.1017 +    else 
  5.1018 +	fn {seedref as ref seed} =>
  5.1019 +	(seedref := nextrand seed; min + (floor(real(max-min) * seed / m)));
  5.1020 +
  5.1021 +fun rangelist (min, max) =
  5.1022 +    if min > max then raise Fail "Random.rangelist: empty range" 
  5.1023 +    else 
  5.1024 +	fn (n, {seedref as ref seed0}) => 
  5.1025 +	let fun h 0 seed res = (seedref := seed; res)
  5.1026 +	      | h i seed res = h (i-1) (nextrand seed) 
  5.1027 +		               (min + floor(real(max-min) * seed / m) :: res)
  5.1028 +	in h n seed0 [] end
  5.1029 +
  5.1030 +end
  5.1031 +end;
  5.1032 +
  5.1033 +(**** Original file: Useful.sig ****)
  5.1034 +
  5.1035 +(* ========================================================================= *)
  5.1036 +(* ML UTILITY FUNCTIONS                                                      *)
  5.1037 +(* Copyright (c) 2001-2005 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.1038 +(* ========================================================================= *)
  5.1039 +
  5.1040 +signature Useful =
  5.1041 +sig
  5.1042 +
  5.1043 +(* ------------------------------------------------------------------------- *)
  5.1044 +(* Exceptions.                                                               *)
  5.1045 +(* ------------------------------------------------------------------------- *)
  5.1046 +
  5.1047 +exception Error of string
  5.1048 +
  5.1049 +exception Bug of string
  5.1050 +
  5.1051 +val partial : exn -> ('a -> 'b option) -> 'a -> 'b
  5.1052 +
  5.1053 +val total : ('a -> 'b) -> 'a -> 'b option
  5.1054 +
  5.1055 +val can : ('a -> 'b) -> 'a -> bool
  5.1056 +
  5.1057 +(* ------------------------------------------------------------------------- *)
  5.1058 +(* Tracing.                                                                  *)
  5.1059 +(* ------------------------------------------------------------------------- *)
  5.1060 +
  5.1061 +val tracePrint : (string -> unit) ref
  5.1062 +
  5.1063 +val maxTraceLevel : int ref
  5.1064 +
  5.1065 +val traceLevel : int ref  (* in the set {0, ..., maxTraceLevel} *)
  5.1066 +
  5.1067 +val traceAlign : {module : string, alignment : int -> int option} list ref
  5.1068 +
  5.1069 +val tracing : {module : string, level : int} -> bool
  5.1070 +
  5.1071 +val trace : string -> unit
  5.1072 +
  5.1073 +(* ------------------------------------------------------------------------- *)
  5.1074 +(* Combinators.                                                              *)
  5.1075 +(* ------------------------------------------------------------------------- *)
  5.1076 +
  5.1077 +val C : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c
  5.1078 +
  5.1079 +val I : 'a -> 'a
  5.1080 +
  5.1081 +val K : 'a -> 'b -> 'a
  5.1082 +
  5.1083 +val S : ('a -> 'b -> 'c) -> ('a -> 'b) -> 'a -> 'c
  5.1084 +
  5.1085 +val W : ('a -> 'a -> 'b) -> 'a -> 'b
  5.1086 +
  5.1087 +val funpow : int -> ('a -> 'a) -> 'a -> 'a
  5.1088 +
  5.1089 +val exp : ('a * 'a -> 'a) -> 'a -> int -> 'a -> 'a
  5.1090 +
  5.1091 +val equal : ''a -> ''a -> bool
  5.1092 +
  5.1093 +val notEqual : ''a -> ''a -> bool
  5.1094 +
  5.1095 +(* ------------------------------------------------------------------------- *)
  5.1096 +(* Pairs.                                                                    *)
  5.1097 +(* ------------------------------------------------------------------------- *)
  5.1098 +
  5.1099 +val fst : 'a * 'b -> 'a
  5.1100 +
  5.1101 +val snd : 'a * 'b -> 'b
  5.1102 +
  5.1103 +val pair : 'a -> 'b -> 'a * 'b
  5.1104 +
  5.1105 +val swap : 'a * 'b -> 'b * 'a
  5.1106 +
  5.1107 +val curry : ('a * 'b -> 'c) -> 'a -> 'b -> 'c
  5.1108 +
  5.1109 +val uncurry : ('a -> 'b -> 'c) -> 'a * 'b -> 'c
  5.1110 +
  5.1111 +val ## : ('a -> 'c) * ('b -> 'd) -> 'a * 'b -> 'c * 'd
  5.1112 +
  5.1113 +(* ------------------------------------------------------------------------- *)
  5.1114 +(* State transformers.                                                       *)
  5.1115 +(* ------------------------------------------------------------------------- *)
  5.1116 +
  5.1117 +val unit : 'a -> 's -> 'a * 's
  5.1118 +
  5.1119 +val bind : ('s -> 'a * 's) -> ('a -> 's -> 'b * 's) -> 's -> 'b * 's
  5.1120 +
  5.1121 +val mmap : ('a -> 'b) -> ('s -> 'a * 's) -> 's -> 'b * 's
  5.1122 +
  5.1123 +val mjoin : ('s -> ('s -> 'a * 's) * 's) -> 's -> 'a * 's
  5.1124 +
  5.1125 +val mwhile : ('a -> bool) -> ('a -> 's -> 'a * 's) -> 'a -> 's -> 'a * 's
  5.1126 +
  5.1127 +(* ------------------------------------------------------------------------- *)
  5.1128 +(* Lists: note we count elements from 0.                                     *)
  5.1129 +(* ------------------------------------------------------------------------- *)
  5.1130 +
  5.1131 +val cons : 'a -> 'a list -> 'a list
  5.1132 +
  5.1133 +val hdTl : 'a list -> 'a * 'a list
  5.1134 +
  5.1135 +val append : 'a list -> 'a list -> 'a list
  5.1136 +
  5.1137 +val singleton : 'a -> 'a list
  5.1138 +
  5.1139 +val first : ('a -> 'b option) -> 'a list -> 'b option
  5.1140 +
  5.1141 +val index : ('a -> bool) -> 'a list -> int option
  5.1142 +
  5.1143 +val maps : ('a -> 's -> 'b * 's) -> 'a list -> 's -> 'b list * 's
  5.1144 +
  5.1145 +val mapsPartial : ('a -> 's -> 'b option * 's) -> 'a list -> 's -> 'b list * 's
  5.1146 +
  5.1147 +val enumerate : 'a list -> (int * 'a) list
  5.1148 +
  5.1149 +val zipwith : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
  5.1150 +
  5.1151 +val zip : 'a list -> 'b list -> ('a * 'b) list
  5.1152 +
  5.1153 +val unzip : ('a * 'b) list -> 'a list * 'b list
  5.1154 +
  5.1155 +val cartwith : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
  5.1156 +
  5.1157 +val cart : 'a list -> 'b list -> ('a * 'b) list
  5.1158 +
  5.1159 +val divide : 'a list -> int -> 'a list * 'a list  (* Subscript *)
  5.1160 +
  5.1161 +val revDivide : 'a list -> int -> 'a list * 'a list  (* Subscript *)
  5.1162 +
  5.1163 +val updateNth : int * 'a -> 'a list -> 'a list  (* Subscript *)
  5.1164 +
  5.1165 +val deleteNth : int -> 'a list -> 'a list  (* Subscript *)
  5.1166 +
  5.1167 +(* ------------------------------------------------------------------------- *)
  5.1168 +(* Sets implemented with lists.                                              *)
  5.1169 +(* ------------------------------------------------------------------------- *)
  5.1170 +
  5.1171 +val mem : ''a -> ''a list -> bool
  5.1172 +
  5.1173 +val insert : ''a -> ''a list -> ''a list
  5.1174 +
  5.1175 +val delete : ''a -> ''a list -> ''a list
  5.1176 +
  5.1177 +val setify : ''a list -> ''a list  (* removes duplicates *)
  5.1178 +
  5.1179 +val union : ''a list -> ''a list -> ''a list
  5.1180 +
  5.1181 +val intersect : ''a list -> ''a list -> ''a list
  5.1182 +
  5.1183 +val difference : ''a list -> ''a list -> ''a list
  5.1184 +
  5.1185 +val subset : ''a list -> ''a list -> bool
  5.1186 +
  5.1187 +val distinct : ''a list -> bool
  5.1188 +
  5.1189 +(* ------------------------------------------------------------------------- *)
  5.1190 +(* Comparisons.                                                              *)
  5.1191 +(* ------------------------------------------------------------------------- *)
  5.1192 +
  5.1193 +val mapCompare : ('a -> 'b) -> ('b * 'b -> order) -> 'a * 'a -> order
  5.1194 +
  5.1195 +val revCompare : ('a * 'a -> order) -> 'a * 'a -> order
  5.1196 +
  5.1197 +val prodCompare :
  5.1198 +    ('a * 'a -> order) -> ('b * 'b -> order) -> ('a * 'b) * ('a * 'b) -> order
  5.1199 +
  5.1200 +val lexCompare : ('a * 'a -> order) -> 'a list * 'a list -> order
  5.1201 +
  5.1202 +val boolCompare : bool * bool -> order  (* true < false *)
  5.1203 +
  5.1204 +(* ------------------------------------------------------------------------- *)
  5.1205 +(* Sorting and searching.                                                    *)
  5.1206 +(* ------------------------------------------------------------------------- *)
  5.1207 +
  5.1208 +val minimum : ('a * 'a -> order) -> 'a list -> 'a * 'a list  (* Empty *)
  5.1209 +
  5.1210 +val maximum : ('a * 'a -> order) -> 'a list -> 'a * 'a list  (* Empty *)
  5.1211 +
  5.1212 +val merge : ('a * 'a -> order) -> 'a list -> 'a list -> 'a list
  5.1213 +
  5.1214 +val sort : ('a * 'a -> order) -> 'a list -> 'a list
  5.1215 +
  5.1216 +val sortMap : ('a -> 'b) -> ('b * 'b -> order) -> 'a list -> 'a list
  5.1217 +
  5.1218 +(* ------------------------------------------------------------------------- *)
  5.1219 +(* Integers.                                                                 *)
  5.1220 +(* ------------------------------------------------------------------------- *)
  5.1221 +
  5.1222 +val interval : int -> int -> int list
  5.1223 +
  5.1224 +val divides : int -> int -> bool
  5.1225 +
  5.1226 +val gcd : int -> int -> int
  5.1227 +
  5.1228 +val primes : int -> int list
  5.1229 +
  5.1230 +val primesUpTo : int -> int list
  5.1231 +
  5.1232 +(* ------------------------------------------------------------------------- *)
  5.1233 +(* Strings.                                                                  *)
  5.1234 +(* ------------------------------------------------------------------------- *)
  5.1235 +
  5.1236 +val rot : int -> char -> char
  5.1237 +
  5.1238 +val charToInt : char -> int option
  5.1239 +
  5.1240 +val charFromInt : int -> char option
  5.1241 +
  5.1242 +val nChars : char -> int -> string
  5.1243 +
  5.1244 +val chomp : string -> string
  5.1245 +
  5.1246 +val trim : string -> string
  5.1247 +
  5.1248 +val join : string -> string list -> string
  5.1249 +
  5.1250 +val split : string -> string -> string list
  5.1251 +
  5.1252 +val mkPrefix : string -> string -> string
  5.1253 +
  5.1254 +val destPrefix : string -> string -> string
  5.1255 +
  5.1256 +val isPrefix : string -> string -> bool
  5.1257 +
  5.1258 +(* ------------------------------------------------------------------------- *)
  5.1259 +(* Tables.                                                                   *)
  5.1260 +(* ------------------------------------------------------------------------- *)
  5.1261 +
  5.1262 +type columnAlignment = {leftAlign : bool, padChar : char}
  5.1263 +
  5.1264 +val alignColumn : columnAlignment -> string list -> string list -> string list
  5.1265 +
  5.1266 +val alignTable : columnAlignment list -> string list list -> string list
  5.1267 +
  5.1268 +(* ------------------------------------------------------------------------- *)
  5.1269 +(* Reals.                                                                    *)
  5.1270 +(* ------------------------------------------------------------------------- *)
  5.1271 +
  5.1272 +val percentToString : real -> string
  5.1273 +
  5.1274 +val pos : real -> real
  5.1275 +
  5.1276 +val log2 : real -> real  (* Domain *)
  5.1277 +
  5.1278 +(* ------------------------------------------------------------------------- *)
  5.1279 +(* Sum datatype.                                                             *)
  5.1280 +(* ------------------------------------------------------------------------- *)
  5.1281 +
  5.1282 +datatype ('a,'b) sum = Left of 'a | Right of 'b
  5.1283 +
  5.1284 +val destLeft : ('a,'b) sum -> 'a
  5.1285 +
  5.1286 +val isLeft : ('a,'b) sum -> bool
  5.1287 +
  5.1288 +val destRight : ('a,'b) sum -> 'b
  5.1289 +
  5.1290 +val isRight : ('a,'b) sum -> bool
  5.1291 +
  5.1292 +(* ------------------------------------------------------------------------- *)
  5.1293 +(* Useful impure features.                                                   *)
  5.1294 +(* ------------------------------------------------------------------------- *)
  5.1295 +
  5.1296 +val newInt : unit -> int
  5.1297 +
  5.1298 +val newInts : int -> int list
  5.1299 +
  5.1300 +val random : int -> int
  5.1301 +
  5.1302 +val uniform : unit -> real
  5.1303 +
  5.1304 +val coinFlip : unit -> bool
  5.1305 +
  5.1306 +val withRef : 'r ref * 'r -> ('a -> 'b) -> 'a -> 'b
  5.1307 +
  5.1308 +(* ------------------------------------------------------------------------- *)
  5.1309 +(* The environment.                                                          *)
  5.1310 +(* ------------------------------------------------------------------------- *)
  5.1311 +
  5.1312 +val host : unit -> string
  5.1313 +
  5.1314 +val time : unit -> string
  5.1315 +
  5.1316 +val date : unit -> string
  5.1317 +
  5.1318 +val readTextFile : {filename : string} -> string
  5.1319 +
  5.1320 +val writeTextFile : {filename : string, contents : string} -> unit
  5.1321 +
  5.1322 +(* ------------------------------------------------------------------------- *)
  5.1323 +(* Profiling and error reporting.                                            *)
  5.1324 +(* ------------------------------------------------------------------------- *)
  5.1325 +
  5.1326 +val try : ('a -> 'b) -> 'a -> 'b
  5.1327 +
  5.1328 +val warn : string -> unit
  5.1329 +
  5.1330 +val die : string -> 'exit
  5.1331 +
  5.1332 +val timed : ('a -> 'b) -> 'a -> real * 'b
  5.1333 +
  5.1334 +val timedMany : ('a -> 'b) -> 'a -> real * 'b
  5.1335 +
  5.1336 +val executionTime : unit -> real  (* Wall clock execution time *)
  5.1337 +
  5.1338 +end
  5.1339 +
  5.1340 +(**** Original file: Useful.sml ****)
  5.1341 +
  5.1342 +structure Metis = struct open Metis
  5.1343 +(* Metis-specific ML environment *)
  5.1344 +nonfix ++ -- RL mem union subset;
  5.1345 +val explode = String.explode;
  5.1346 +val implode = String.implode;
  5.1347 +val print = TextIO.print;
  5.1348 +(* ========================================================================= *)
  5.1349 +(* ML UTILITY FUNCTIONS                                                      *)
  5.1350 +(* Copyright (c) 2001-2004 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.1351 +(* ========================================================================= *)
  5.1352 +
  5.1353 +structure Useful :> Useful =
  5.1354 +struct
  5.1355 +
  5.1356 +infixr 0 oo ## |->
  5.1357 +
  5.1358 +(* ------------------------------------------------------------------------- *)
  5.1359 +(* Exceptions                                                                *)
  5.1360 +(* ------------------------------------------------------------------------- *)
  5.1361 +
  5.1362 +exception Error of string;
  5.1363 +
  5.1364 +exception Bug of string;
  5.1365 +
  5.1366 +fun errorToString (Error message) = "\nError: " ^ message ^ "\n"
  5.1367 +  | errorToString _ = raise Bug "errorToString: not an Error exception";
  5.1368 +
  5.1369 +fun bugToString (Bug message) = "\nBug: " ^ message ^ "\n"
  5.1370 +  | bugToString _ = raise Bug "bugToString: not a Bug exception";
  5.1371 +
  5.1372 +fun total f x = SOME (f x) handle Error _ => NONE;
  5.1373 +
  5.1374 +fun can f = Option.isSome o total f;
  5.1375 +
  5.1376 +fun partial (e as Error _) f x = (case f x of SOME y => y | NONE => raise e)
  5.1377 +  | partial _ _ _ = raise Bug "partial: must take an Error exception";
  5.1378 +
  5.1379 +(* ------------------------------------------------------------------------- *)
  5.1380 +(* Tracing                                                                   *)
  5.1381 +(* ------------------------------------------------------------------------- *)
  5.1382 +
  5.1383 +val tracePrint = ref print;
  5.1384 +
  5.1385 +val maxTraceLevel = ref 10;
  5.1386 +
  5.1387 +val traceLevel = ref 1;
  5.1388 +
  5.1389 +val traceAlign : {module : string, alignment : int -> int option} list ref
  5.1390 +  = ref [];
  5.1391 +
  5.1392 +local
  5.1393 +  fun query m l t =
  5.1394 +      case List.find (fn {module, ...} => module = m) (!traceAlign) of
  5.1395 +        NONE => l <= t
  5.1396 +      | SOME {alignment,...} =>
  5.1397 +        case alignment l of NONE => false | SOME l => l <= t;
  5.1398 +in
  5.1399 +  fun tracing {module,level} =
  5.1400 +    let
  5.1401 +      val ref T = maxTraceLevel
  5.1402 +      and ref t = traceLevel
  5.1403 +    in
  5.1404 +      0 < t andalso (T <= t orelse query module level t)
  5.1405 +    end;
  5.1406 +end;
  5.1407 +
  5.1408 +fun trace message = !tracePrint message;
  5.1409 +
  5.1410 +(* ------------------------------------------------------------------------- *)
  5.1411 +(* Combinators                                                               *)
  5.1412 +(* ------------------------------------------------------------------------- *)
  5.1413 +
  5.1414 +fun C f x y = f y x;
  5.1415 +
  5.1416 +fun I x = x;
  5.1417 +
  5.1418 +fun K x y = x;
  5.1419 +
  5.1420 +fun S f g x = f x (g x);
  5.1421 +
  5.1422 +fun W f x = f x x;
  5.1423 +
  5.1424 +fun funpow 0 _ x = x
  5.1425 +  | funpow n f x = funpow (n - 1) f (f x);
  5.1426 +
  5.1427 +fun exp m =
  5.1428 +    let
  5.1429 +      fun f _ 0 z = z
  5.1430 +        | f x y z = f (m (x,x)) (y div 2) (if y mod 2 = 0 then z else m (z,x))
  5.1431 +    in
  5.1432 +      f
  5.1433 +    end;
  5.1434 +
  5.1435 +val equal = fn x => fn y => x = y;
  5.1436 +
  5.1437 +val notEqual = fn x => fn y => x <> y;
  5.1438 +
  5.1439 +(* ------------------------------------------------------------------------- *)
  5.1440 +(* Pairs                                                                     *)
  5.1441 +(* ------------------------------------------------------------------------- *)
  5.1442 +
  5.1443 +fun fst (x,_) = x;
  5.1444 +
  5.1445 +fun snd (_,y) = y;
  5.1446 +
  5.1447 +fun pair x y = (x,y);
  5.1448 +
  5.1449 +fun swap (x,y) = (y,x);
  5.1450 +
  5.1451 +fun curry f x y = f (x,y);
  5.1452 +
  5.1453 +fun uncurry f (x,y) = f x y;
  5.1454 +
  5.1455 +val op## = fn (f,g) => fn (x,y) => (f x, g y);
  5.1456 +
  5.1457 +(* ------------------------------------------------------------------------- *)
  5.1458 +(* State transformers                                                        *)
  5.1459 +(* ------------------------------------------------------------------------- *)
  5.1460 +
  5.1461 +val unit : 'a -> 's -> 'a * 's = pair;
  5.1462 +
  5.1463 +fun bind f (g : 'a -> 's -> 'b * 's) = uncurry g o f;
  5.1464 +
  5.1465 +fun mmap f (m : 's -> 'a * 's) = bind m (unit o f);
  5.1466 +
  5.1467 +fun mjoin (f : 's -> ('s -> 'a * 's) * 's) = bind f I;
  5.1468 +
  5.1469 +fun mwhile c b = let fun f a = if c a then bind (b a) f else unit a in f end;
  5.1470 +
  5.1471 +(* ------------------------------------------------------------------------- *)
  5.1472 +(* Lists                                                                     *)
  5.1473 +(* ------------------------------------------------------------------------- *)
  5.1474 +
  5.1475 +fun cons x y = x :: y;
  5.1476 +
  5.1477 +fun hdTl l = (hd l, tl l);
  5.1478 +
  5.1479 +fun append xs ys = xs @ ys;
  5.1480 +
  5.1481 +fun singleton a = [a];
  5.1482 +
  5.1483 +fun first f [] = NONE
  5.1484 +  | first f (x :: xs) = (case f x of NONE => first f xs | s => s);
  5.1485 +
  5.1486 +fun index p =
  5.1487 +  let
  5.1488 +    fun idx _ [] = NONE
  5.1489 +      | idx n (x :: xs) = if p x then SOME n else idx (n + 1) xs
  5.1490 +  in
  5.1491 +    idx 0
  5.1492 +  end;
  5.1493 +
  5.1494 +fun maps (_ : 'a -> 's -> 'b * 's) [] = unit []
  5.1495 +  | maps f (x :: xs) =
  5.1496 +    bind (f x) (fn y => bind (maps f xs) (fn ys => unit (y :: ys)));
  5.1497 +
  5.1498 +fun mapsPartial (_ : 'a -> 's -> 'b option * 's) [] = unit []
  5.1499 +  | mapsPartial f (x :: xs) =
  5.1500 +    bind
  5.1501 +      (f x)
  5.1502 +      (fn yo =>
  5.1503 +          bind
  5.1504 +            (mapsPartial f xs)
  5.1505 +            (fn ys => unit (case yo of NONE => ys | SOME y => y :: ys)));
  5.1506 +
  5.1507 +fun enumerate l = fst (maps (fn x => fn m => ((m, x), m + 1)) l 0);
  5.1508 +
  5.1509 +fun zipwith f =
  5.1510 +    let
  5.1511 +      fun z l [] [] = l
  5.1512 +        | z l (x :: xs) (y :: ys) = z (f x y :: l) xs ys
  5.1513 +        | z _ _ _ = raise Error "zipwith: lists different lengths";
  5.1514 +    in
  5.1515 +      fn xs => fn ys => rev (z [] xs ys)
  5.1516 +    end;
  5.1517 +
  5.1518 +fun zip xs ys = zipwith pair xs ys;
  5.1519 +
  5.1520 +fun unzip ab =
  5.1521 +    foldl (fn ((x, y), (xs, ys)) => (x :: xs, y :: ys)) ([], []) (rev ab);
  5.1522 +
  5.1523 +fun cartwith f =
  5.1524 +  let
  5.1525 +    fun aux _ res _ [] = res
  5.1526 +      | aux xsCopy res [] (y :: yt) = aux xsCopy res xsCopy yt
  5.1527 +      | aux xsCopy res (x :: xt) (ys as y :: _) =
  5.1528 +        aux xsCopy (f x y :: res) xt ys
  5.1529 +  in
  5.1530 +    fn xs => fn ys =>
  5.1531 +    let val xs' = rev xs in aux xs' [] xs' (rev ys) end
  5.1532 +  end;
  5.1533 +
  5.1534 +fun cart xs ys = cartwith pair xs ys;
  5.1535 +
  5.1536 +local
  5.1537 +  fun revDiv acc l 0 = (acc,l)
  5.1538 +    | revDiv _ [] _ = raise Subscript
  5.1539 +    | revDiv acc (h :: t) n = revDiv (h :: acc) t (n - 1);
  5.1540 +in
  5.1541 +  fun revDivide l = revDiv [] l;
  5.1542 +end;
  5.1543 +
  5.1544 +fun divide l n = let val (a,b) = revDivide l n in (rev a, b) end;
  5.1545 +
  5.1546 +fun updateNth (n,x) l =
  5.1547 +    let
  5.1548 +      val (a,b) = revDivide l n
  5.1549 +    in
  5.1550 +      case b of [] => raise Subscript | _ :: t => List.revAppend (a, x :: t)
  5.1551 +    end;
  5.1552 +
  5.1553 +fun deleteNth n l =
  5.1554 +    let
  5.1555 +      val (a,b) = revDivide l n
  5.1556 +    in
  5.1557 +      case b of [] => raise Subscript | _ :: t => List.revAppend (a,t)
  5.1558 +    end;
  5.1559 +
  5.1560 +(* ------------------------------------------------------------------------- *)
  5.1561 +(* Sets implemented with lists                                               *)
  5.1562 +(* ------------------------------------------------------------------------- *)
  5.1563 +
  5.1564 +fun mem x = List.exists (equal x);
  5.1565 +
  5.1566 +fun insert x s = if mem x s then s else x :: s;
  5.1567 +
  5.1568 +fun delete x s = List.filter (not o equal x) s;
  5.1569 +
  5.1570 +fun setify s = rev (foldl (fn (v,x) => if mem v x then x else v :: x) [] s);
  5.1571 +
  5.1572 +fun union s t = foldl (fn (v,x) => if mem v t then x else v :: x) t (rev s);
  5.1573 +
  5.1574 +fun intersect s t =
  5.1575 +    foldl (fn (v,x) => if mem v t then v :: x else x) [] (rev s);
  5.1576 +
  5.1577 +fun difference s t =
  5.1578 +    foldl (fn (v,x) => if mem v t then x else v :: x) [] (rev s);
  5.1579 +
  5.1580 +fun subset s t = List.all (fn x => mem x t) s;
  5.1581 +
  5.1582 +fun distinct [] = true
  5.1583 +  | distinct (x :: rest) = not (mem x rest) andalso distinct rest;
  5.1584 +
  5.1585 +(* ------------------------------------------------------------------------- *)
  5.1586 +(* Comparisons.                                                              *)
  5.1587 +(* ------------------------------------------------------------------------- *)
  5.1588 +
  5.1589 +fun mapCompare f cmp (a,b) = cmp (f a, f b);
  5.1590 +
  5.1591 +fun revCompare cmp x_y =
  5.1592 +    case cmp x_y of LESS => GREATER | EQUAL => EQUAL | GREATER => LESS;
  5.1593 +
  5.1594 +fun prodCompare xCmp yCmp ((x1,y1),(x2,y2)) =
  5.1595 +    case xCmp (x1,x2) of
  5.1596 +      LESS => LESS
  5.1597 +    | EQUAL => yCmp (y1,y2)
  5.1598 +    | GREATER => GREATER;
  5.1599 +
  5.1600 +fun lexCompare cmp =
  5.1601 +    let
  5.1602 +      fun lex ([],[]) = EQUAL
  5.1603 +        | lex ([], _ :: _) = LESS
  5.1604 +        | lex (_ :: _, []) = GREATER
  5.1605 +        | lex (x :: xs, y :: ys) =
  5.1606 +          case cmp (x,y) of
  5.1607 +            LESS => LESS
  5.1608 +          | EQUAL => lex (xs,ys)
  5.1609 +          | GREATER => GREATER
  5.1610 +    in
  5.1611 +      lex
  5.1612 +    end;
  5.1613 +
  5.1614 +fun boolCompare (true,false) = LESS
  5.1615 +  | boolCompare (false,true) = GREATER
  5.1616 +  | boolCompare _ = EQUAL;
  5.1617 +
  5.1618 +(* ------------------------------------------------------------------------- *)
  5.1619 +(* Sorting and searching.                                                    *)
  5.1620 +(* ------------------------------------------------------------------------- *)
  5.1621 +
  5.1622 +(* Finding the minimum and maximum element of a list, wrt some order. *)
  5.1623 +
  5.1624 +fun minimum cmp =
  5.1625 +    let
  5.1626 +      fun min (l,m,r) _ [] = (m, List.revAppend (l,r))
  5.1627 +        | min (best as (_,m,_)) l (x :: r) =
  5.1628 +          min (case cmp (x,m) of LESS => (l,x,r) | _ => best) (x :: l) r
  5.1629 +    in
  5.1630 +      fn [] => raise Empty
  5.1631 +       | h :: t => min ([],h,t) [h] t
  5.1632 +    end;
  5.1633 +
  5.1634 +fun maximum cmp = minimum (revCompare cmp);
  5.1635 +
  5.1636 +(* Merge (for the following merge-sort, but generally useful too). *)
  5.1637 +
  5.1638 +fun merge cmp =
  5.1639 +    let
  5.1640 +      fun mrg acc [] ys = List.revAppend (acc,ys)
  5.1641 +        | mrg acc xs [] = List.revAppend (acc,xs)
  5.1642 +        | mrg acc (xs as x :: xt) (ys as y :: yt) =
  5.1643 +          (case cmp (x,y) of
  5.1644 +             GREATER => mrg (y :: acc) xs yt
  5.1645 +           | _ => mrg (x :: acc) xt ys)
  5.1646 +    in
  5.1647 +      mrg []
  5.1648 +    end;
  5.1649 +
  5.1650 +(* Merge sort (stable). *)
  5.1651 +
  5.1652 +fun sort cmp =
  5.1653 +    let
  5.1654 +      fun findRuns acc r rs [] = rev (rev (r :: rs) :: acc)
  5.1655 +        | findRuns acc r rs (x :: xs) =
  5.1656 +          case cmp (r,x) of
  5.1657 +            GREATER => findRuns (rev (r :: rs) :: acc) x [] xs
  5.1658 +          | _ => findRuns acc x (r :: rs) xs
  5.1659 +
  5.1660 +      fun mergeAdj acc [] = rev acc
  5.1661 +        | mergeAdj acc (xs as [_]) = List.revAppend (acc,xs)
  5.1662 +        | mergeAdj acc (x :: y :: xs) = mergeAdj (merge cmp x y :: acc) xs
  5.1663 +
  5.1664 +      fun mergePairs [xs] = xs
  5.1665 +        | mergePairs l = mergePairs (mergeAdj [] l)
  5.1666 +    in
  5.1667 +      fn [] => []
  5.1668 +       | l as [_] => l
  5.1669 +       | h :: t => mergePairs (findRuns [] h [] t)
  5.1670 +    end;
  5.1671 +    
  5.1672 +fun sortMap _ _ [] = []
  5.1673 +  | sortMap _ _ (l as [_]) = l
  5.1674 +  | sortMap f cmp xs =
  5.1675 +    let
  5.1676 +      fun ncmp ((m,_),(n,_)) = cmp (m,n)
  5.1677 +      val nxs = map (fn x => (f x, x)) xs
  5.1678 +      val nys = sort ncmp nxs
  5.1679 +    in
  5.1680 +      map snd nys
  5.1681 +    end;
  5.1682 +
  5.1683 +(* ------------------------------------------------------------------------- *)
  5.1684 +(* Integers.                                                                 *)
  5.1685 +(* ------------------------------------------------------------------------- *)
  5.1686 +
  5.1687 +fun interval m 0 = []
  5.1688 +  | interval m len = m :: interval (m + 1) (len - 1);
  5.1689 +
  5.1690 +fun divides _ 0 = true
  5.1691 +  | divides 0 _ = false
  5.1692 +  | divides a b = b mod (Int.abs a) = 0;
  5.1693 +
  5.1694 +local
  5.1695 +  fun hcf 0 n = n
  5.1696 +    | hcf 1 _ = 1
  5.1697 +    | hcf m n = hcf (n mod m) m;
  5.1698 +in
  5.1699 +  fun gcd m n =
  5.1700 +      let
  5.1701 +        val m = Int.abs m
  5.1702 +        and n = Int.abs n
  5.1703 +      in
  5.1704 +        if m < n then hcf m n else hcf n m
  5.1705 +      end;
  5.1706 +end;
  5.1707 +
  5.1708 +local
  5.1709 +  fun both f g n = f n andalso g n;
  5.1710 +
  5.1711 +  fun next f = let fun nx x = if f x then x else nx (x + 1) in nx end;
  5.1712 +
  5.1713 +  fun looking res 0 _ _ = rev res
  5.1714 +    | looking res n f x =
  5.1715 +      let
  5.1716 +        val p = next f x
  5.1717 +        val res' = p :: res
  5.1718 +        val f' = both f (not o divides p)
  5.1719 +      in
  5.1720 +        looking res' (n - 1) f' (p + 1)
  5.1721 +      end;
  5.1722 +
  5.1723 +  fun calcPrimes n = looking [] n (K true) 2
  5.1724 +
  5.1725 +  val primesList = ref (calcPrimes 10);
  5.1726 +in
  5.1727 +  fun primes n =
  5.1728 +      if length (!primesList) <= n then List.take (!primesList,n)
  5.1729 +      else
  5.1730 +        let
  5.1731 +          val l = calcPrimes n
  5.1732 +          val () = primesList := l
  5.1733 +        in
  5.1734 +          l
  5.1735 +        end;
  5.1736 +
  5.1737 +  fun primesUpTo n =
  5.1738 +      let
  5.1739 +        fun f k [] =
  5.1740 +            let
  5.1741 +              val l = calcPrimes (2 * k)
  5.1742 +              val () = primesList := l
  5.1743 +            in
  5.1744 +              f k (List.drop (l,k))
  5.1745 +            end
  5.1746 +          | f k (p :: ps) =
  5.1747 +            if p <= n then f (k + 1) ps else List.take (!primesList, k)
  5.1748 +      in
  5.1749 +        f 0 (!primesList)
  5.1750 +      end;
  5.1751 +end;
  5.1752 +
  5.1753 +(* ------------------------------------------------------------------------- *)
  5.1754 +(* Strings.                                                                  *)
  5.1755 +(* ------------------------------------------------------------------------- *)
  5.1756 +
  5.1757 +local
  5.1758 +  fun len l = (length l, l)
  5.1759 +
  5.1760 +  val upper = len (explode "ABCDEFGHIJKLMNOPQRSTUVWXYZ");
  5.1761 +
  5.1762 +  val lower = len (explode "abcdefghijklmnopqrstuvwxyz");
  5.1763 +
  5.1764 +  fun rotate (n,l) c k =
  5.1765 +      List.nth (l, (k + Option.valOf (index (equal c) l)) mod n);
  5.1766 +in
  5.1767 +  fun rot k c =
  5.1768 +      if Char.isLower c then rotate lower c k
  5.1769 +      else if Char.isUpper c then rotate upper c k
  5.1770 +      else c;
  5.1771 +end;
  5.1772 +
  5.1773 +fun charToInt #"0" = SOME 0
  5.1774 +  | charToInt #"1" = SOME 1
  5.1775 +  | charToInt #"2" = SOME 2
  5.1776 +  | charToInt #"3" = SOME 3
  5.1777 +  | charToInt #"4" = SOME 4
  5.1778 +  | charToInt #"5" = SOME 5
  5.1779 +  | charToInt #"6" = SOME 6
  5.1780 +  | charToInt #"7" = SOME 7
  5.1781 +  | charToInt #"8" = SOME 8
  5.1782 +  | charToInt #"9" = SOME 9
  5.1783 +  | charToInt _ = NONE;
  5.1784 +
  5.1785 +fun charFromInt 0 = SOME #"0"
  5.1786 +  | charFromInt 1 = SOME #"1"
  5.1787 +  | charFromInt 2 = SOME #"2"
  5.1788 +  | charFromInt 3 = SOME #"3"
  5.1789 +  | charFromInt 4 = SOME #"4"
  5.1790 +  | charFromInt 5 = SOME #"5"
  5.1791 +  | charFromInt 6 = SOME #"6"
  5.1792 +  | charFromInt 7 = SOME #"7"
  5.1793 +  | charFromInt 8 = SOME #"8"
  5.1794 +  | charFromInt 9 = SOME #"9"
  5.1795 +  | charFromInt _ = NONE;
  5.1796 +
  5.1797 +fun nChars x =
  5.1798 +    let
  5.1799 +      fun dup 0 l = l | dup n l = dup (n - 1) (x :: l)
  5.1800 +    in
  5.1801 +      fn n => implode (dup n [])
  5.1802 +    end;
  5.1803 +
  5.1804 +fun chomp s =
  5.1805 +    let
  5.1806 +      val n = size s
  5.1807 +    in
  5.1808 +      if n = 0 orelse String.sub (s, n - 1) <> #"\n" then s
  5.1809 +      else String.substring (s, 0, n - 1)
  5.1810 +    end;
  5.1811 +
  5.1812 +local
  5.1813 +  fun chop [] = []
  5.1814 +    | chop (l as (h :: t)) = if Char.isSpace h then chop t else l;
  5.1815 +in
  5.1816 +  val trim = implode o chop o rev o chop o rev o explode;
  5.1817 +end;
  5.1818 +
  5.1819 +fun join _ [] = "" | join s (h :: t) = foldl (fn (x,y) => y ^ s ^ x) h t;
  5.1820 +
  5.1821 +local
  5.1822 +  fun match [] l = SOME l
  5.1823 +    | match _ [] = NONE
  5.1824 +    | match (x :: xs) (y :: ys) = if x = y then match xs ys else NONE;
  5.1825 +
  5.1826 +  fun stringify acc [] = acc
  5.1827 +    | stringify acc (h :: t) = stringify (implode h :: acc) t;
  5.1828 +in
  5.1829 +  fun split sep =
  5.1830 +      let
  5.1831 +        val pat = String.explode sep
  5.1832 +        fun div1 prev recent [] = stringify [] (rev recent :: prev)
  5.1833 +          | div1 prev recent (l as h :: t) =
  5.1834 +            case match pat l of
  5.1835 +              NONE => div1 prev (h :: recent) t
  5.1836 +            | SOME rest => div1 (rev recent :: prev) [] rest
  5.1837 +      in
  5.1838 +        fn s => div1 [] [] (explode s)
  5.1839 +      end;
  5.1840 +end;
  5.1841 +
  5.1842 +(***
  5.1843 +fun pluralize {singular,plural} = fn 1 => singular | _ => plural;
  5.1844 +***)
  5.1845 +
  5.1846 +fun mkPrefix p s = p ^ s;
  5.1847 +
  5.1848 +fun destPrefix p =
  5.1849 +    let
  5.1850 +      fun check s = String.isPrefix p s orelse raise Error "destPrefix"
  5.1851 +
  5.1852 +      val sizeP = size p
  5.1853 +    in
  5.1854 +      fn s => (check s; String.extract (s,sizeP,NONE))
  5.1855 +    end;
  5.1856 +
  5.1857 +fun isPrefix p = can (destPrefix p);
  5.1858 +
  5.1859 +(* ------------------------------------------------------------------------- *)
  5.1860 +(* Tables.                                                                   *)
  5.1861 +(* ------------------------------------------------------------------------- *)
  5.1862 +
  5.1863 +type columnAlignment = {leftAlign : bool, padChar : char}
  5.1864 +
  5.1865 +fun alignColumn {leftAlign,padChar} column =
  5.1866 +    let
  5.1867 +      val (n,_) = maximum Int.compare (map size column)
  5.1868 +
  5.1869 +      fun pad entry row =
  5.1870 +          let
  5.1871 +            val padding = nChars padChar (n - size entry)
  5.1872 +          in
  5.1873 +            if leftAlign then entry ^ padding ^ row
  5.1874 +            else padding ^ entry ^ row
  5.1875 +          end
  5.1876 +    in
  5.1877 +      zipwith pad column
  5.1878 +    end;
  5.1879 +
  5.1880 +fun alignTable [] rows = map (K "") rows
  5.1881 +  | alignTable [{leftAlign = true, padChar = #" "}] rows = map hd rows
  5.1882 +  | alignTable (align :: aligns) rows =
  5.1883 +    alignColumn align (map hd rows) (alignTable aligns (map tl rows));
  5.1884 +
  5.1885 +(* ------------------------------------------------------------------------- *)
  5.1886 +(* Reals.                                                                    *)
  5.1887 +(* ------------------------------------------------------------------------- *)
  5.1888 +
  5.1889 +val realToString = Real.toString;
  5.1890 +
  5.1891 +fun percentToString x = Int.toString (Real.round (100.0 * x)) ^ "%";
  5.1892 +
  5.1893 +fun pos r = Real.max (r,0.0);
  5.1894 +
  5.1895 +local val ln2 = Math.ln 2.0 in fun log2 x = Math.ln x / ln2 end;
  5.1896 +
  5.1897 +(* ------------------------------------------------------------------------- *)
  5.1898 +(* Sums.                                                                     *)
  5.1899 +(* ------------------------------------------------------------------------- *)
  5.1900 +
  5.1901 +datatype ('a,'b) sum = Left of 'a | Right of 'b
  5.1902 +
  5.1903 +fun destLeft (Left l) = l
  5.1904 +  | destLeft _ = raise Error "destLeft";
  5.1905 +
  5.1906 +fun isLeft (Left _) = true
  5.1907 +  | isLeft (Right _) = false;
  5.1908 +
  5.1909 +fun destRight (Right r) = r
  5.1910 +  | destRight _ = raise Error "destRight";
  5.1911 +
  5.1912 +fun isRight (Left _) = false
  5.1913 +  | isRight (Right _) = true;
  5.1914 +
  5.1915 +(* ------------------------------------------------------------------------- *)
  5.1916 +(* Useful impure features.                                                   *)
  5.1917 +(* ------------------------------------------------------------------------- *)
  5.1918 +
  5.1919 +local
  5.1920 +  val generator = ref 0
  5.1921 +in
  5.1922 +  fun newInt () =
  5.1923 +      let
  5.1924 +        val n = !generator
  5.1925 +        val () = generator := n + 1
  5.1926 +      in
  5.1927 +        n
  5.1928 +      end;
  5.1929 +
  5.1930 +  fun newInts 0 = []
  5.1931 +    | newInts k =
  5.1932 +      let
  5.1933 +        val n = !generator
  5.1934 +        val () = generator := n + k
  5.1935 +      in
  5.1936 +        interval n k
  5.1937 +      end;
  5.1938 +end;
  5.1939 +
  5.1940 +local
  5.1941 +  val gen = Random.newgenseed 1.0;
  5.1942 +in
  5.1943 +  fun random max = Random.range (0,max) gen;
  5.1944 +
  5.1945 +  fun uniform () = Random.random gen;
  5.1946 +
  5.1947 +  fun coinFlip () = Random.range (0,2) gen = 0;
  5.1948 +end;
  5.1949 +
  5.1950 +fun withRef (r,new) f x =
  5.1951 +  let
  5.1952 +    val old = !r
  5.1953 +    val () = r := new
  5.1954 +    val y = f x handle e => (r := old; raise e)
  5.1955 +    val () = r := old
  5.1956 +  in
  5.1957 +    y
  5.1958 +  end;
  5.1959 +
  5.1960 +(* ------------------------------------------------------------------------- *)
  5.1961 +(* Environment.                                                              *)
  5.1962 +(* ------------------------------------------------------------------------- *)
  5.1963 +
  5.1964 +fun host () = Option.getOpt (OS.Process.getEnv "HOSTNAME", "unknown");
  5.1965 +
  5.1966 +fun time () = Date.fmt "%H:%M:%S" (Date.fromTimeLocal (Time.now ()));
  5.1967 +
  5.1968 +fun date () = Date.fmt "%d/%m/%Y" (Date.fromTimeLocal (Time.now ()));
  5.1969 +
  5.1970 +fun readTextFile {filename} =
  5.1971 +  let
  5.1972 +    open TextIO
  5.1973 +    val h = openIn filename
  5.1974 +    val contents = inputAll h
  5.1975 +    val () = closeIn h
  5.1976 +  in
  5.1977 +    contents
  5.1978 +  end;
  5.1979 +
  5.1980 +fun writeTextFile {filename,contents} =
  5.1981 +  let
  5.1982 +    open TextIO
  5.1983 +    val h = openOut filename
  5.1984 +    val () = output (h,contents)
  5.1985 +    val () = closeOut h
  5.1986 +  in
  5.1987 +    ()
  5.1988 +  end;
  5.1989 +
  5.1990 +(* ------------------------------------------------------------------------- *)
  5.1991 +(* Profiling                                                                 *)
  5.1992 +(* ------------------------------------------------------------------------- *)
  5.1993 +
  5.1994 +local
  5.1995 +  fun err x s = TextIO.output (TextIO.stdErr, x ^ ": " ^ s ^ "\n");
  5.1996 +in
  5.1997 +  fun try f x = f x
  5.1998 +      handle e as Error _ => (err "try" (errorToString e); raise e)
  5.1999 +           | e as Bug _ => (err "try" (bugToString e); raise e)
  5.2000 +           | e => (err "try" "strange exception raised"; raise e);
  5.2001 +
  5.2002 +  val warn = err "WARNING";
  5.2003 +
  5.2004 +  fun die s = (err "\nFATAL ERROR" s; OS.Process.exit OS.Process.failure);
  5.2005 +end;
  5.2006 +
  5.2007 +fun timed f a =
  5.2008 +  let
  5.2009 +    val tmr = Timer.startCPUTimer ()
  5.2010 +    val res = f a
  5.2011 +    val {usr,sys,...} = Timer.checkCPUTimer tmr
  5.2012 +  in
  5.2013 +    (Time.toReal usr + Time.toReal sys, res)
  5.2014 +  end;
  5.2015 +
  5.2016 +local
  5.2017 +  val MIN = 1.0;
  5.2018 +
  5.2019 +  fun several n t f a =
  5.2020 +    let
  5.2021 +      val (t',res) = timed f a
  5.2022 +      val t = t + t'
  5.2023 +      val n = n + 1
  5.2024 +    in
  5.2025 +      if t > MIN then (t / Real.fromInt n, res) else several n t f a
  5.2026 +    end;
  5.2027 +in
  5.2028 +  fun timedMany f a = several 0 0.0 f a
  5.2029 +end;
  5.2030 +
  5.2031 +val executionTime =
  5.2032 +    let
  5.2033 +      val startTime = Time.toReal (Time.now ())
  5.2034 +    in
  5.2035 +      fn () => Time.toReal (Time.now ()) - startTime
  5.2036 +    end;
  5.2037 +
  5.2038 +end
  5.2039 +end;
  5.2040 +
  5.2041 +(**** Original file: Lazy.sig ****)
  5.2042 +
  5.2043 +(* ========================================================================= *)
  5.2044 +(* SUPPORT FOR LAZY EVALUATION                                               *)
  5.2045 +(* Copyright (c) 2007 Joe Hurd, distributed under the GNU GPL version 2      *)
  5.2046 +(* ========================================================================= *)
  5.2047 +
  5.2048 +signature Lazy =
  5.2049 +sig
  5.2050 +
  5.2051 +type 'a lazy
  5.2052 +
  5.2053 +val delay : (unit -> 'a) -> 'a lazy
  5.2054 +
  5.2055 +val force : 'a lazy -> 'a
  5.2056 +
  5.2057 +val memoize : (unit -> 'a) -> unit -> 'a
  5.2058 +
  5.2059 +end
  5.2060 +
  5.2061 +(**** Original file: Lazy.sml ****)
  5.2062 +
  5.2063 +structure Metis = struct open Metis
  5.2064 +(* Metis-specific ML environment *)
  5.2065 +nonfix ++ -- RL mem union subset;
  5.2066 +val explode = String.explode;
  5.2067 +val implode = String.implode;
  5.2068 +val print = TextIO.print;
  5.2069 +(* ========================================================================= *)
  5.2070 +(* SUPPORT FOR LAZY EVALUATION                                               *)
  5.2071 +(* Copyright (c) 2007 Joe Hurd, distributed under the GNU GPL version 2      *)
  5.2072 +(* ========================================================================= *)
  5.2073 +
  5.2074 +structure Lazy :> Lazy =
  5.2075 +struct
  5.2076 +
  5.2077 +datatype 'a thunk =
  5.2078 +    Value of 'a
  5.2079 +  | Thunk of unit -> 'a;
  5.2080 +
  5.2081 +datatype 'a lazy = Lazy of 'a thunk ref;
  5.2082 +
  5.2083 +fun delay f = Lazy (ref (Thunk f));
  5.2084 +
  5.2085 +fun force (Lazy (ref (Value v))) = v
  5.2086 +  | force (Lazy (s as ref (Thunk f))) =
  5.2087 +    let
  5.2088 +      val v = f ()
  5.2089 +      val () = s := Value v
  5.2090 +    in
  5.2091 +      v
  5.2092 +    end;
  5.2093 +
  5.2094 +fun memoize f =
  5.2095 +    let
  5.2096 +      val t = delay f
  5.2097 +    in
  5.2098 +      fn () => force t
  5.2099 +    end;
  5.2100 +
  5.2101 +end
  5.2102 +end;
  5.2103 +
  5.2104 +(**** Original file: Ordered.sig ****)
  5.2105 +
  5.2106 +(* ========================================================================= *)
  5.2107 +(* ORDERED TYPES                                                             *)
  5.2108 +(* Copyright (c) 2004-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.2109 +(* ========================================================================= *)
  5.2110 +
  5.2111 +signature Ordered =
  5.2112 +sig
  5.2113 +
  5.2114 +type t
  5.2115 +
  5.2116 +val compare : t * t -> order
  5.2117 +
  5.2118 +(*
  5.2119 +  PROVIDES
  5.2120 +
  5.2121 +  !x : t. compare (x,x) = EQUAL
  5.2122 +
  5.2123 +  !x y : t. compare (x,y) = LESS <=> compare (y,x) = GREATER
  5.2124 +
  5.2125 +  !x y : t. compare (x,y) = EQUAL ==> compare (y,x) = EQUAL
  5.2126 +
  5.2127 +  !x y z : t. compare (x,y) = EQUAL ==> compare (x,z) = compare (y,z)
  5.2128 +
  5.2129 +  !x y z : t.
  5.2130 +    compare (x,y) = LESS andalso compare (y,z) = LESS ==>
  5.2131 +    compare (x,z) = LESS
  5.2132 +
  5.2133 +  !x y z : t.
  5.2134 +    compare (x,y) = GREATER andalso compare (y,z) = GREATER ==>
  5.2135 +    compare (x,z) = GREATER
  5.2136 +*)
  5.2137 +
  5.2138 +end
  5.2139 +
  5.2140 +(**** Original file: Ordered.sml ****)
  5.2141 +
  5.2142 +structure Metis = struct open Metis
  5.2143 +(* Metis-specific ML environment *)
  5.2144 +nonfix ++ -- RL mem union subset;
  5.2145 +val explode = String.explode;
  5.2146 +val implode = String.implode;
  5.2147 +val print = TextIO.print;
  5.2148 +(* ========================================================================= *)
  5.2149 +(* ORDERED TYPES                                                             *)
  5.2150 +(* Copyright (c) 2004-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.2151 +(* ========================================================================= *)
  5.2152 +
  5.2153 +structure IntOrdered =
  5.2154 +struct type t = int val compare = Int.compare end;
  5.2155 +
  5.2156 +structure StringOrdered =
  5.2157 +struct type t = string val compare = String.compare end;
  5.2158 +end;
  5.2159 +
  5.2160 +(**** Original file: Set.sig ****)
  5.2161 +
  5.2162 +(* ========================================================================= *)
  5.2163 +(* FINITE SETS                                                               *)
  5.2164 +(* Copyright (c) 2004-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.2165 +(* ========================================================================= *)
  5.2166 +
  5.2167 +signature Set =
  5.2168 +sig
  5.2169 +
  5.2170 +(* ------------------------------------------------------------------------- *)
  5.2171 +(* Finite sets                                                               *)
  5.2172 +(* ------------------------------------------------------------------------- *)
  5.2173 +
  5.2174 +type 'elt set
  5.2175 +
  5.2176 +val comparison : 'elt set -> ('elt * 'elt -> order)
  5.2177 +
  5.2178 +val empty : ('elt * 'elt -> order) -> 'elt set
  5.2179 +
  5.2180 +val singleton : ('elt * 'elt -> order) -> 'elt -> 'elt set
  5.2181 +
  5.2182 +val null : 'elt set -> bool
  5.2183 +
  5.2184 +val size : 'elt set -> int
  5.2185 +
  5.2186 +val member : 'elt -> 'elt set -> bool
  5.2187 +
  5.2188 +val add : 'elt set -> 'elt -> 'elt set
  5.2189 +
  5.2190 +val addList : 'elt set -> 'elt list -> 'elt set
  5.2191 +
  5.2192 +val delete : 'elt set -> 'elt -> 'elt set  (* raises Error *)
  5.2193 +
  5.2194 +(* Union and intersect prefer elements in the second set *)
  5.2195 +
  5.2196 +val union : 'elt set -> 'elt set -> 'elt set
  5.2197 +
  5.2198 +val unionList : 'elt set list -> 'elt set
  5.2199 +
  5.2200 +val intersect : 'elt set -> 'elt set -> 'elt set
  5.2201 +
  5.2202 +val intersectList : 'elt set list -> 'elt set
  5.2203 +
  5.2204 +val difference : 'elt set -> 'elt set -> 'elt set
  5.2205 +
  5.2206 +val symmetricDifference : 'elt set -> 'elt set -> 'elt set
  5.2207 +
  5.2208 +val disjoint : 'elt set -> 'elt set -> bool
  5.2209 +
  5.2210 +val subset : 'elt set -> 'elt set -> bool
  5.2211 +
  5.2212 +val equal : 'elt set -> 'elt set -> bool
  5.2213 +
  5.2214 +val filter : ('elt -> bool) -> 'elt set -> 'elt set
  5.2215 +
  5.2216 +val partition : ('elt -> bool) -> 'elt set -> 'elt set * 'elt set
  5.2217 +
  5.2218 +val count : ('elt -> bool) -> 'elt set -> int
  5.2219 +
  5.2220 +val foldl : ('elt * 's -> 's) -> 's -> 'elt set -> 's
  5.2221 +
  5.2222 +val foldr : ('elt * 's -> 's) -> 's -> 'elt set -> 's
  5.2223 +
  5.2224 +val findl : ('elt -> bool) -> 'elt set -> 'elt option
  5.2225 +
  5.2226 +val findr : ('elt -> bool) -> 'elt set -> 'elt option
  5.2227 +
  5.2228 +val firstl : ('elt -> 'a option) -> 'elt set -> 'a option
  5.2229 +
  5.2230 +val firstr : ('elt -> 'a option) -> 'elt set -> 'a option
  5.2231 +
  5.2232 +val exists : ('elt -> bool) -> 'elt set -> bool
  5.2233 +
  5.2234 +val all : ('elt -> bool) -> 'elt set -> bool
  5.2235 +
  5.2236 +val map : ('elt -> 'a) -> 'elt set -> ('elt * 'a) list
  5.2237 +
  5.2238 +val transform : ('elt -> 'a) -> 'elt set -> 'a list
  5.2239 +
  5.2240 +val app : ('elt -> unit) -> 'elt set -> unit
  5.2241 +
  5.2242 +val toList : 'elt set -> 'elt list
  5.2243 +
  5.2244 +val fromList : ('elt * 'elt -> order) -> 'elt list -> 'elt set
  5.2245 +
  5.2246 +val pick : 'elt set -> 'elt  (* raises Empty *)
  5.2247 +
  5.2248 +val random : 'elt set -> 'elt  (* raises Empty *)
  5.2249 +
  5.2250 +val deletePick : 'elt set -> 'elt * 'elt set  (* raises Empty *)
  5.2251 +
  5.2252 +val deleteRandom : 'elt set -> 'elt * 'elt set  (* raises Empty *)
  5.2253 +
  5.2254 +val compare : 'elt set * 'elt set -> order
  5.2255 +
  5.2256 +val close : ('elt set -> 'elt set) -> 'elt set -> 'elt set
  5.2257 +
  5.2258 +val toString : 'elt set -> string
  5.2259 +
  5.2260 +(* ------------------------------------------------------------------------- *)
  5.2261 +(* Iterators over sets                                                       *)
  5.2262 +(* ------------------------------------------------------------------------- *)
  5.2263 +
  5.2264 +type 'elt iterator
  5.2265 +
  5.2266 +val mkIterator : 'elt set -> 'elt iterator option
  5.2267 +
  5.2268 +val mkRevIterator : 'elt set -> 'elt iterator option
  5.2269 +
  5.2270 +val readIterator : 'elt iterator -> 'elt
  5.2271 +
  5.2272 +val advanceIterator : 'elt iterator -> 'elt iterator option
  5.2273 +
  5.2274 +end
  5.2275 +
  5.2276 +(**** Original file: RandomSet.sml ****)
  5.2277 +
  5.2278 +structure Metis = struct open Metis
  5.2279 +(* Metis-specific ML environment *)
  5.2280 +nonfix ++ -- RL mem union subset;
  5.2281 +val explode = String.explode;
  5.2282 +val implode = String.implode;
  5.2283 +val print = TextIO.print;
  5.2284 +(* ========================================================================= *)
  5.2285 +(* FINITE SETS IMPLEMENTED WITH RANDOMLY BALANCED TREES                      *)
  5.2286 +(* Copyright (c) 2004-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.2287 +(* ========================================================================= *)
  5.2288 +
  5.2289 +structure RandomSet :> Set =
  5.2290 +struct
  5.2291 +
  5.2292 +exception Bug = Useful.Bug;
  5.2293 +
  5.2294 +exception Error = Useful.Error;
  5.2295 +
  5.2296 +val pointerEqual = Portable.pointerEqual;
  5.2297 +
  5.2298 +val K = Useful.K;
  5.2299 +
  5.2300 +val snd = Useful.snd;
  5.2301 +
  5.2302 +val randomInt = Useful.random;
  5.2303 +
  5.2304 +(* ------------------------------------------------------------------------- *)
  5.2305 +(* Random search trees.                                                      *)
  5.2306 +(* ------------------------------------------------------------------------- *)
  5.2307 +
  5.2308 +datatype 'a tree =
  5.2309 +    E
  5.2310 +  | T of
  5.2311 +    {size : int,
  5.2312 +     priority : real,
  5.2313 +     left : 'a tree,
  5.2314 +     key : 'a,
  5.2315 +     right : 'a tree};
  5.2316 +    
  5.2317 +type 'a node =
  5.2318 +     {size : int,
  5.2319 +      priority : real,
  5.2320 +      left : 'a tree,
  5.2321 +      key : 'a,
  5.2322 +      right : 'a tree};
  5.2323 +
  5.2324 +datatype 'a set = Set of ('a * 'a -> order) * 'a tree;
  5.2325 +
  5.2326 +(* ------------------------------------------------------------------------- *)
  5.2327 +(* Random priorities.                                                        *)
  5.2328 +(* ------------------------------------------------------------------------- *)
  5.2329 +
  5.2330 +local
  5.2331 +  val randomPriority =
  5.2332 +      let
  5.2333 +        val gen = Random.newgenseed 2.0
  5.2334 +      in
  5.2335 +        fn () => Random.random gen
  5.2336 +      end;
  5.2337 +
  5.2338 +  val priorityOrder = Real.compare;
  5.2339 +in
  5.2340 +  fun treeSingleton key =
  5.2341 +      T {size = 1, priority = randomPriority (),
  5.2342 +         left = E, key = key, right = E};
  5.2343 +
  5.2344 +  fun nodePriorityOrder cmp (x1 : 'a node, x2 : 'a node) =
  5.2345 +      let
  5.2346 +        val {priority = p1, key = k1, ...} = x1
  5.2347 +        and {priority = p2, key = k2, ...} = x2
  5.2348 +      in
  5.2349 +        case priorityOrder (p1,p2) of
  5.2350 +          LESS => LESS
  5.2351 +        | EQUAL => cmp (k1,k2)
  5.2352 +        | GREATER => GREATER
  5.2353 +      end;
  5.2354 +end;
  5.2355 +
  5.2356 +(* ------------------------------------------------------------------------- *)
  5.2357 +(* Debugging functions.                                                      *)
  5.2358 +(* ------------------------------------------------------------------------- *)
  5.2359 +
  5.2360 +local
  5.2361 +  fun checkSizes E = 0
  5.2362 +    | checkSizes (T {size,left,right,...}) =
  5.2363 +      let
  5.2364 +        val l = checkSizes left
  5.2365 +        and r = checkSizes right
  5.2366 +        val () = if l + 1 + r = size then () else raise Error "wrong size"
  5.2367 +      in
  5.2368 +        size
  5.2369 +      end
  5.2370 +
  5.2371 +  fun checkSorted _ x E = x
  5.2372 +    | checkSorted cmp x (T {left,key,right,...}) =
  5.2373 +      let
  5.2374 +        val x = checkSorted cmp x left
  5.2375 +        val () =
  5.2376 +            case x of
  5.2377 +              NONE => ()
  5.2378 +            | SOME k =>
  5.2379 +              case cmp (k,key) of
  5.2380 +                LESS => ()
  5.2381 +              | EQUAL => raise Error "duplicate keys"
  5.2382 +              | GREATER => raise Error "unsorted"
  5.2383 +      in
  5.2384 +        checkSorted cmp (SOME key) right
  5.2385 +      end;
  5.2386 +
  5.2387 +  fun checkPriorities _ E = NONE
  5.2388 +    | checkPriorities cmp (T (x as {left,right,...})) =
  5.2389 +      let
  5.2390 +        val () =
  5.2391 +            case checkPriorities cmp left of
  5.2392 +              NONE => ()
  5.2393 +            | SOME l =>
  5.2394 +              case nodePriorityOrder cmp (l,x) of
  5.2395 +                LESS => ()
  5.2396 +              | EQUAL => raise Error "left child has equal key"
  5.2397 +              | GREATER => raise Error "left child has greater priority"
  5.2398 +        val () =
  5.2399 +            case checkPriorities cmp right of
  5.2400 +              NONE => ()
  5.2401 +            | SOME r =>
  5.2402 +              case nodePriorityOrder cmp (r,x) of
  5.2403 +                LESS => ()
  5.2404 +              | EQUAL => raise Error "right child has equal key"
  5.2405 +              | GREATER => raise Error "right child has greater priority"
  5.2406 +      in
  5.2407 +        SOME x
  5.2408 +      end;
  5.2409 +in
  5.2410 +  fun checkWellformed s (set as Set (cmp,tree)) =
  5.2411 +      (let
  5.2412 +         val _ = checkSizes tree
  5.2413 +         val _ = checkSorted cmp NONE tree
  5.2414 +         val _ = checkPriorities cmp tree
  5.2415 +       in
  5.2416 +         set
  5.2417 +       end
  5.2418 +       handle Error err => raise Bug err)
  5.2419 +      handle Bug bug => raise Bug (s ^ "\nRandomSet.checkWellformed: " ^ bug);
  5.2420 +end;
  5.2421 +
  5.2422 +(* ------------------------------------------------------------------------- *)
  5.2423 +(* Basic operations.                                                         *)
  5.2424 +(* ------------------------------------------------------------------------- *)
  5.2425 +
  5.2426 +fun comparison (Set (cmp,_)) = cmp;
  5.2427 +
  5.2428 +fun empty cmp = Set (cmp,E);
  5.2429 +
  5.2430 +fun treeSize E = 0
  5.2431 +  | treeSize (T {size = s, ...}) = s;
  5.2432 +
  5.2433 +fun size (Set (_,tree)) = treeSize tree;
  5.2434 +
  5.2435 +fun mkT p l k r =
  5.2436 +    T {size = treeSize l + 1 + treeSize r, priority = p,
  5.2437 +       left = l, key = k, right = r};
  5.2438 +
  5.2439 +fun singleton cmp key = Set (cmp, treeSingleton key);
  5.2440 +
  5.2441 +local
  5.2442 +  fun treePeek cmp E pkey = NONE
  5.2443 +    | treePeek cmp (T {left,key,right,...}) pkey =
  5.2444 +      case cmp (pkey,key) of
  5.2445 +        LESS => treePeek cmp left pkey
  5.2446 +      | EQUAL => SOME key
  5.2447 +      | GREATER => treePeek cmp right pkey
  5.2448 +in
  5.2449 +  fun peek (Set (cmp,tree)) key = treePeek cmp tree key;
  5.2450 +end;
  5.2451 +
  5.2452 +(* treeAppend assumes that every element of the first tree is less than *)
  5.2453 +(* every element of the second tree. *)
  5.2454 +
  5.2455 +fun treeAppend _ t1 E = t1
  5.2456 +  | treeAppend _ E t2 = t2
  5.2457 +  | treeAppend cmp (t1 as T x1) (t2 as T x2) =
  5.2458 +    case nodePriorityOrder cmp (x1,x2) of
  5.2459 +      LESS =>
  5.2460 +      let
  5.2461 +        val {priority = p2, left = l2, key = k2, right = r2, ...} = x2
  5.2462 +      in
  5.2463 +        mkT p2 (treeAppend cmp t1 l2) k2 r2
  5.2464 +      end
  5.2465 +    | EQUAL => raise Bug "RandomSet.treeAppend: equal keys"
  5.2466 +    | GREATER =>
  5.2467 +      let
  5.2468 +        val {priority = p1, left = l1, key = k1, right = r1, ...} = x1
  5.2469 +      in
  5.2470 +        mkT p1 l1 k1 (treeAppend cmp r1 t2)
  5.2471 +      end;
  5.2472 +
  5.2473 +(* nodePartition splits the node into three parts: the keys comparing less *)
  5.2474 +(* than the supplied key, an optional equal key, and the keys comparing *)
  5.2475 +(* greater. *)
  5.2476 +
  5.2477 +local
  5.2478 +  fun mkLeft [] t = t
  5.2479 +    | mkLeft (({priority,left,key,...} : 'a node) :: xs) t =
  5.2480 +      mkLeft xs (mkT priority left key t);
  5.2481 +
  5.2482 +  fun mkRight [] t = t
  5.2483 +    | mkRight (({priority,key,right,...} : 'a node) :: xs) t =
  5.2484 +      mkRight xs (mkT priority t key right);
  5.2485 +
  5.2486 +  fun treePart _ _ lefts rights E = (mkLeft lefts E, NONE, mkRight rights E)
  5.2487 +    | treePart cmp pkey lefts rights (T x) = nodePart cmp pkey lefts rights x
  5.2488 +  and nodePart cmp pkey lefts rights (x as {left,key,right,...}) =
  5.2489 +      case cmp (pkey,key) of
  5.2490 +        LESS => treePart cmp pkey lefts (x :: rights) left
  5.2491 +      | EQUAL => (mkLeft lefts left, SOME key, mkRight rights right)
  5.2492 +      | GREATER => treePart cmp pkey (x :: lefts) rights right;
  5.2493 +in
  5.2494 +  fun nodePartition cmp x pkey = nodePart cmp pkey [] [] x;
  5.2495 +end;
  5.2496 +
  5.2497 +(* union first calls treeCombineRemove, to combine the values *)
  5.2498 +(* for equal keys into the first map and remove them from the second map. *)
  5.2499 +(* Note that the combined key is always the one from the second map. *)
  5.2500 +
  5.2501 +local
  5.2502 +  fun treeCombineRemove _ t1 E = (t1,E)
  5.2503 +    | treeCombineRemove _ E t2 = (E,t2)
  5.2504 +    | treeCombineRemove cmp (t1 as T x1) (t2 as T x2) =
  5.2505 +      let
  5.2506 +        val {priority = p1, left = l1, key = k1, right = r1, ...} = x1
  5.2507 +        val (l2,k2,r2) = nodePartition cmp x2 k1
  5.2508 +        val (l1,l2) = treeCombineRemove cmp l1 l2
  5.2509 +        and (r1,r2) = treeCombineRemove cmp r1 r2
  5.2510 +      in
  5.2511 +        case k2 of
  5.2512 +          NONE => if treeSize l2 + treeSize r2 = #size x2 then (t1,t2)
  5.2513 +                  else (mkT p1 l1 k1 r1, treeAppend cmp l2 r2)
  5.2514 +        | SOME k2 => (mkT p1 l1 k2 r1, treeAppend cmp l2 r2)
  5.2515 +      end;
  5.2516 +
  5.2517 +  fun treeUnionDisjoint _ t1 E = t1
  5.2518 +    | treeUnionDisjoint _ E t2 = t2
  5.2519 +    | treeUnionDisjoint cmp (T x1) (T x2) =
  5.2520 +      case nodePriorityOrder cmp (x1,x2) of
  5.2521 +        LESS => nodeUnionDisjoint cmp x2 x1
  5.2522 +      | EQUAL => raise Bug "RandomSet.unionDisjoint: equal keys"
  5.2523 +      | GREATER => nodeUnionDisjoint cmp x1 x2
  5.2524 +
  5.2525 +  and nodeUnionDisjoint cmp x1 x2 =
  5.2526 +      let
  5.2527 +        val {priority = p1, left = l1, key = k1, right = r1, ...} = x1
  5.2528 +        val (l2,_,r2) = nodePartition cmp x2 k1
  5.2529 +        val l = treeUnionDisjoint cmp l1 l2
  5.2530 +        and r = treeUnionDisjoint cmp r1 r2
  5.2531 +      in
  5.2532 +        mkT p1 l k1 r
  5.2533 +      end;
  5.2534 +in
  5.2535 +  fun union (s1 as Set (cmp,t1)) (Set (_,t2)) =
  5.2536 +      if pointerEqual (t1,t2) then s1
  5.2537 +      else
  5.2538 +        let
  5.2539 +          val (t1,t2) = treeCombineRemove cmp t1 t2
  5.2540 +        in
  5.2541 +          Set (cmp, treeUnionDisjoint cmp t1 t2)
  5.2542 +        end;
  5.2543 +end;
  5.2544 +
  5.2545 +(*DEBUG
  5.2546 +val union = fn t1 => fn t2 =>
  5.2547 +    checkWellformed "RandomSet.union: result"
  5.2548 +      (union (checkWellformed "RandomSet.union: input 1" t1)
  5.2549 +             (checkWellformed "RandomSet.union: input 2" t2));
  5.2550 +*)
  5.2551 +
  5.2552 +(* intersect is a simple case of the union algorithm. *)
  5.2553 +
  5.2554 +local
  5.2555 +  fun treeIntersect _ _ E = E
  5.2556 +    | treeIntersect _ E _ = E
  5.2557 +    | treeIntersect cmp (t1 as T x1) (t2 as T x2) =
  5.2558 +      let
  5.2559 +        val {priority = p1, left = l1, key = k1, right = r1, ...} = x1
  5.2560 +        val (l2,k2,r2) = nodePartition cmp x2 k1
  5.2561 +        val l = treeIntersect cmp l1 l2
  5.2562 +        and r = treeIntersect cmp r1 r2
  5.2563 +      in
  5.2564 +        case k2 of
  5.2565 +          NONE => treeAppend cmp l r
  5.2566 +        | SOME k2 => mkT p1 l k2 r
  5.2567 +      end;
  5.2568 +in
  5.2569 +  fun intersect (s1 as Set (cmp,t1)) (Set (_,t2)) =
  5.2570 +      if pointerEqual (t1,t2) then s1
  5.2571 +      else Set (cmp, treeIntersect cmp t1 t2);
  5.2572 +end;
  5.2573 +
  5.2574 +(*DEBUG
  5.2575 +val intersect = fn t1 => fn t2 =>
  5.2576 +    checkWellformed "RandomSet.intersect: result"
  5.2577 +      (intersect (checkWellformed "RandomSet.intersect: input 1" t1)
  5.2578 +                 (checkWellformed "RandomSet.intersect: input 2" t2));
  5.2579 +*)
  5.2580 +
  5.2581 +(* delete raises an exception if the supplied key is not found, which *)
  5.2582 +(* makes it simpler to maximize sharing. *)
  5.2583 +
  5.2584 +local
  5.2585 +  fun treeDelete _ E _ = raise Error "RandomSet.delete: element not found"
  5.2586 +    | treeDelete cmp (T {priority,left,key,right,...}) dkey =
  5.2587 +      case cmp (dkey,key) of
  5.2588 +        LESS => mkT priority (treeDelete cmp left dkey) key right
  5.2589 +      | EQUAL => treeAppend cmp left right
  5.2590 +      | GREATER => mkT priority left key (treeDelete cmp right dkey);
  5.2591 +in
  5.2592 +  fun delete (Set (cmp,tree)) key = Set (cmp, treeDelete cmp tree key);
  5.2593 +end;
  5.2594 + 
  5.2595 +(*DEBUG
  5.2596 +val delete = fn t => fn x =>
  5.2597 +    checkWellformed "RandomSet.delete: result"
  5.2598 +      (delete (checkWellformed "RandomSet.delete: input" t) x);
  5.2599 +*)
  5.2600 +
  5.2601 +(* Set difference *)
  5.2602 +
  5.2603 +local
  5.2604 +  fun treeDifference _ t1 E = t1
  5.2605 +    | treeDifference _ E _ = E
  5.2606 +    | treeDifference cmp (t1 as T x1) (T x2) =
  5.2607 +      let
  5.2608 +        val {size = s1, priority = p1, left = l1, key = k1, right = r1} = x1
  5.2609 +        val (l2,k2,r2) = nodePartition cmp x2 k1
  5.2610 +        val l = treeDifference cmp l1 l2
  5.2611 +        and r = treeDifference cmp r1 r2
  5.2612 +      in
  5.2613 +        if Option.isSome k2 then treeAppend cmp l r
  5.2614 +        else if treeSize l + treeSize r + 1 = s1 then t1
  5.2615 +        else mkT p1 l k1 r
  5.2616 +      end;
  5.2617 +in
  5.2618 +  fun difference (Set (cmp,tree1)) (Set (_,tree2)) =
  5.2619 +      if pointerEqual (tree1,tree2) then Set (cmp,E)
  5.2620 +      else Set (cmp, treeDifference cmp tree1 tree2);
  5.2621 +end;
  5.2622 +
  5.2623 +(*DEBUG
  5.2624 +val difference = fn t1 => fn t2 =>
  5.2625 +    checkWellformed "RandomSet.difference: result"
  5.2626 +      (difference (checkWellformed "RandomSet.difference: input 1" t1)
  5.2627 +                  (checkWellformed "RandomSet.difference: input 2" t2));
  5.2628 +*)
  5.2629 +
  5.2630 +(* Subsets *)
  5.2631 +
  5.2632 +local
  5.2633 +  fun treeSubset _ E _ = true
  5.2634 +    | treeSubset _ _ E = false
  5.2635 +    | treeSubset cmp (t1 as T x1) (T x2) =
  5.2636 +      let
  5.2637 +        val {size = s1, left = l1, key = k1, right = r1, ...} = x1
  5.2638 +        and {size = s2, ...} = x2
  5.2639 +      in
  5.2640 +        s1 <= s2 andalso
  5.2641 +        let
  5.2642 +          val (l2,k2,r2) = nodePartition cmp x2 k1
  5.2643 +        in
  5.2644 +          Option.isSome k2 andalso
  5.2645 +          treeSubset cmp l1 l2 andalso
  5.2646 +          treeSubset cmp r1 r2
  5.2647 +        end
  5.2648 +      end;
  5.2649 +in
  5.2650 +  fun subset (Set (cmp,tree1)) (Set (_,tree2)) =
  5.2651 +      pointerEqual (tree1,tree2) orelse
  5.2652 +      treeSubset cmp tree1 tree2;
  5.2653 +end;
  5.2654 +
  5.2655 +(* Set equality *)
  5.2656 +
  5.2657 +local
  5.2658 +  fun treeEqual _ E E = true
  5.2659 +    | treeEqual _ E _ = false
  5.2660 +    | treeEqual _ _ E = false
  5.2661 +    | treeEqual cmp (t1 as T x1) (T x2) =
  5.2662 +      let
  5.2663 +        val {size = s1, left = l1, key = k1, right = r1, ...} = x1
  5.2664 +        and {size = s2, ...} = x2
  5.2665 +      in
  5.2666 +        s1 = s2 andalso
  5.2667 +        let
  5.2668 +          val (l2,k2,r2) = nodePartition cmp x2 k1
  5.2669 +        in
  5.2670 +          Option.isSome k2 andalso
  5.2671 +          treeEqual cmp l1 l2 andalso
  5.2672 +          treeEqual cmp r1 r2
  5.2673 +        end
  5.2674 +      end;
  5.2675 +in
  5.2676 +  fun equal (Set (cmp,tree1)) (Set (_,tree2)) =
  5.2677 +      pointerEqual (tree1,tree2) orelse
  5.2678 +      treeEqual cmp tree1 tree2;
  5.2679 +end;
  5.2680 +
  5.2681 +(* filter is the basic function for preserving the tree structure. *)
  5.2682 +
  5.2683 +local
  5.2684 +  fun treeFilter _ _ E = E
  5.2685 +    | treeFilter cmp pred (T {priority,left,key,right,...}) =
  5.2686 +      let
  5.2687 +        val left = treeFilter cmp pred left
  5.2688 +        and right = treeFilter cmp pred right
  5.2689 +      in
  5.2690 +        if pred key then mkT priority left key right
  5.2691 +        else treeAppend cmp left right
  5.2692 +      end;
  5.2693 +in
  5.2694 +  fun filter pred (Set (cmp,tree)) = Set (cmp, treeFilter cmp pred tree);
  5.2695 +end;
  5.2696 +
  5.2697 +(* nth picks the nth smallest key (counting from 0). *)
  5.2698 +
  5.2699 +local
  5.2700 +  fun treeNth E _ = raise Subscript
  5.2701 +    | treeNth (T {left,key,right,...}) n =
  5.2702 +      let
  5.2703 +        val k = treeSize left
  5.2704 +      in
  5.2705 +        if n = k then key
  5.2706 +        else if n < k then treeNth left n
  5.2707 +        else treeNth right (n - (k + 1))
  5.2708 +      end;
  5.2709 +in
  5.2710 +  fun nth (Set (_,tree)) n = treeNth tree n;
  5.2711 +end;
  5.2712 +
  5.2713 +(* ------------------------------------------------------------------------- *)
  5.2714 +(* Iterators.                                                                *)
  5.2715 +(* ------------------------------------------------------------------------- *)
  5.2716 +
  5.2717 +fun leftSpine E acc = acc
  5.2718 +  | leftSpine (t as T {left,...}) acc = leftSpine left (t :: acc);
  5.2719 +
  5.2720 +fun rightSpine E acc = acc
  5.2721 +  | rightSpine (t as T {right,...}) acc = rightSpine right (t :: acc);
  5.2722 +
  5.2723 +datatype 'a iterator =
  5.2724 +    LR of 'a * 'a tree * 'a tree list
  5.2725 +  | RL of 'a * 'a tree * 'a tree list;
  5.2726 +
  5.2727 +fun mkLR [] = NONE
  5.2728 +  | mkLR (T {key,right,...} :: l) = SOME (LR (key,right,l))
  5.2729 +  | mkLR (E :: _) = raise Bug "RandomSet.mkLR";
  5.2730 +
  5.2731 +fun mkRL [] = NONE
  5.2732 +  | mkRL (T {key,left,...} :: l) = SOME (RL (key,left,l))
  5.2733 +  | mkRL (E :: _) = raise Bug "RandomSet.mkRL";
  5.2734 +
  5.2735 +fun mkIterator (Set (_,tree)) = mkLR (leftSpine tree []);
  5.2736 +
  5.2737 +fun mkRevIterator (Set (_,tree)) = mkRL (rightSpine tree []);
  5.2738 +
  5.2739 +fun readIterator (LR (key,_,_)) = key
  5.2740 +  | readIterator (RL (key,_,_)) = key;
  5.2741 +
  5.2742 +fun advanceIterator (LR (_,next,l)) = mkLR (leftSpine next l)
  5.2743 +  | advanceIterator (RL (_,next,l)) = mkRL (rightSpine next l);
  5.2744 +
  5.2745 +(* ------------------------------------------------------------------------- *)
  5.2746 +(* Derived operations.                                                       *)
  5.2747 +(* ------------------------------------------------------------------------- *)
  5.2748 +
  5.2749 +fun null s = size s = 0;
  5.2750 +
  5.2751 +fun member x s = Option.isSome (peek s x);
  5.2752 +
  5.2753 +(* add must be primitive to get hold of the comparison function *)
  5.2754 +
  5.2755 +fun add s x = union s (singleton (comparison s) x);
  5.2756 +
  5.2757 +(*DEBUG
  5.2758 +val add = fn s => fn x =>
  5.2759 +    checkWellformed "RandomSet.add: result"
  5.2760 +      (add (checkWellformed "RandomSet.add: input" s) x);
  5.2761 +*)
  5.2762 +
  5.2763 +local
  5.2764 +  fun unionPairs ys [] = rev ys
  5.2765 +    | unionPairs ys (xs as [_]) = List.revAppend (ys,xs)
  5.2766 +    | unionPairs ys (x1 :: x2 :: xs) = unionPairs (union x1 x2 :: ys) xs;
  5.2767 +in
  5.2768 +  fun unionList [] = raise Error "Set.unionList: no sets"
  5.2769 +    | unionList [s] = s
  5.2770 +    | unionList l = unionList (unionPairs [] l);
  5.2771 +end;
  5.2772 +
  5.2773 +local
  5.2774 +  fun intersectPairs ys [] = rev ys
  5.2775 +    | intersectPairs ys (xs as [_]) = List.revAppend (ys,xs)
  5.2776 +    | intersectPairs ys (x1 :: x2 :: xs) =
  5.2777 +      intersectPairs (intersect x1 x2 :: ys) xs;
  5.2778 +in
  5.2779 +  fun intersectList [] = raise Error "Set.intersectList: no sets"
  5.2780 +    | intersectList [s] = s
  5.2781 +    | intersectList l = intersectList (intersectPairs [] l);
  5.2782 +end;
  5.2783 +
  5.2784 +fun symmetricDifference s1 s2 = union (difference s1 s2) (difference s2 s1);
  5.2785 +
  5.2786 +fun disjoint s1 s2 = null (intersect s1 s2);
  5.2787 +
  5.2788 +fun partition pred set = (filter pred set, filter (not o pred) set);
  5.2789 +
  5.2790 +local
  5.2791 +  fun fold _ NONE acc = acc
  5.2792 +    | fold f (SOME iter) acc =
  5.2793 +      let
  5.2794 +        val key = readIterator iter
  5.2795 +      in
  5.2796 +        fold f (advanceIterator iter) (f (key,acc))
  5.2797 +      end;
  5.2798 +in
  5.2799 +  fun foldl f b m = fold f (mkIterator m) b;
  5.2800 +
  5.2801 +  fun foldr f b m = fold f (mkRevIterator m) b;
  5.2802 +end;
  5.2803 +
  5.2804 +local
  5.2805 +  fun find _ NONE = NONE
  5.2806 +    | find pred (SOME iter) =
  5.2807 +      let
  5.2808 +        val key = readIterator iter
  5.2809 +      in
  5.2810 +        if pred key then SOME key
  5.2811 +        else find pred (advanceIterator iter)
  5.2812 +      end;
  5.2813 +in
  5.2814 +  fun findl p m = find p (mkIterator m);
  5.2815 +
  5.2816 +  fun findr p m = find p (mkRevIterator m);
  5.2817 +end;
  5.2818 +
  5.2819 +local
  5.2820 +  fun first _ NONE = NONE
  5.2821 +    | first f (SOME iter) =
  5.2822 +      let
  5.2823 +        val key = readIterator iter
  5.2824 +      in
  5.2825 +        case f key of
  5.2826 +          NONE => first f (advanceIterator iter)
  5.2827 +        | s => s
  5.2828 +      end;
  5.2829 +in
  5.2830 +  fun firstl f m = first f (mkIterator m);
  5.2831 +
  5.2832 +  fun firstr f m = first f (mkRevIterator m);
  5.2833 +end;
  5.2834 +
  5.2835 +fun count p = foldl (fn (x,n) => if p x then n + 1 else n) 0;
  5.2836 +
  5.2837 +fun fromList cmp l = List.foldl (fn (k,s) => add s k) (empty cmp) l;
  5.2838 +
  5.2839 +fun addList s l = union s (fromList (comparison s) l);
  5.2840 +
  5.2841 +fun toList s = foldr op:: [] s;
  5.2842 +
  5.2843 +fun map f s = rev (foldl (fn (x,l) => (x, f x) :: l) [] s);
  5.2844 +
  5.2845 +fun transform f s = rev (foldl (fn (x,l) => f x :: l) [] s);
  5.2846 +
  5.2847 +fun app f s = foldl (fn (x,()) => f x) () s;
  5.2848 +
  5.2849 +fun exists p s = Option.isSome (findl p s);
  5.2850 +
  5.2851 +fun all p s = not (exists (not o p) s);
  5.2852 +
  5.2853 +local
  5.2854 +  fun iterCompare _ NONE NONE = EQUAL
  5.2855 +    | iterCompare _ NONE (SOME _) = LESS
  5.2856 +    | iterCompare _ (SOME _) NONE = GREATER
  5.2857 +    | iterCompare cmp (SOME i1) (SOME i2) =
  5.2858 +      keyIterCompare cmp (readIterator i1) (readIterator i2) i1 i2
  5.2859 +
  5.2860 +  and keyIterCompare cmp k1 k2 i1 i2 =
  5.2861 +      case cmp (k1,k2) of
  5.2862 +        LESS => LESS
  5.2863 +      | EQUAL => iterCompare cmp (advanceIterator i1) (advanceIterator i2)
  5.2864 +      | GREATER => GREATER;
  5.2865 +in
  5.2866 +  fun compare (s1,s2) =
  5.2867 +      if pointerEqual (s1,s2) then EQUAL
  5.2868 +      else
  5.2869 +        case Int.compare (size s1, size s2) of
  5.2870 +          LESS => LESS
  5.2871 +        | EQUAL => iterCompare (comparison s1) (mkIterator s1) (mkIterator s2)
  5.2872 +        | GREATER => GREATER;
  5.2873 +end;
  5.2874 +
  5.2875 +fun pick s =
  5.2876 +    case findl (K true) s of
  5.2877 +      SOME p => p
  5.2878 +    | NONE => raise Error "RandomSet.pick: empty";
  5.2879 +
  5.2880 +fun random s = case size s of 0 => raise Empty | n => nth s (randomInt n);
  5.2881 +
  5.2882 +fun deletePick s = let val x = pick s in (x, delete s x) end;
  5.2883 +
  5.2884 +fun deleteRandom s = let val x = random s in (x, delete s x) end;
  5.2885 +
  5.2886 +fun close f s = let val s' = f s in if equal s s' then s else close f s' end;
  5.2887 +
  5.2888 +fun toString s = "{" ^ (if null s then "" else Int.toString (size s)) ^ "}";
  5.2889 +
  5.2890 +end
  5.2891 +end;
  5.2892 +
  5.2893 +(**** Original file: Set.sml ****)
  5.2894 +
  5.2895 +structure Metis = struct open Metis
  5.2896 +(* Metis-specific ML environment *)
  5.2897 +nonfix ++ -- RL mem union subset;
  5.2898 +val explode = String.explode;
  5.2899 +val implode = String.implode;
  5.2900 +val print = TextIO.print;
  5.2901 +(* ========================================================================= *)
  5.2902 +(* FINITE SETS                                                               *)
  5.2903 +(* Copyright (c) 2004-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.2904 +(* ========================================================================= *)
  5.2905 +
  5.2906 +structure Set = RandomSet;
  5.2907 +end;
  5.2908 +
  5.2909 +(**** Original file: ElementSet.sig ****)
  5.2910 +
  5.2911 +(* ========================================================================= *)
  5.2912 +(* FINITE SETS WITH A FIXED ELEMENT TYPE                                     *)
  5.2913 +(* Copyright (c) 2004-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.2914 +(* ========================================================================= *)
  5.2915 +
  5.2916 +signature ElementSet =
  5.2917 +sig
  5.2918 +
  5.2919 +type element
  5.2920 +
  5.2921 +(* ------------------------------------------------------------------------- *)
  5.2922 +(* Finite sets                                                               *)
  5.2923 +(* ------------------------------------------------------------------------- *)
  5.2924 +
  5.2925 +type set
  5.2926 +
  5.2927 +val empty : set
  5.2928 +
  5.2929 +val singleton : element -> set
  5.2930 +
  5.2931 +val null : set -> bool
  5.2932 +
  5.2933 +val size : set -> int
  5.2934 +
  5.2935 +val member : element -> set -> bool
  5.2936 +
  5.2937 +val add : set -> element -> set
  5.2938 +
  5.2939 +val addList : set -> element list -> set
  5.2940 +
  5.2941 +val delete : set -> element -> set  (* raises Error *)
  5.2942 +
  5.2943 +(* Union and intersect prefer elements in the second set *)
  5.2944 +
  5.2945 +val union : set -> set -> set
  5.2946 +
  5.2947 +val unionList : set list -> set
  5.2948 +
  5.2949 +val intersect : set -> set -> set
  5.2950 +
  5.2951 +val intersectList : set list -> set
  5.2952 +
  5.2953 +val difference : set -> set -> set
  5.2954 +
  5.2955 +val symmetricDifference : set -> set -> set
  5.2956 +
  5.2957 +val disjoint : set -> set -> bool
  5.2958 +
  5.2959 +val subset : set -> set -> bool
  5.2960 +
  5.2961 +val equal : set -> set -> bool
  5.2962 +
  5.2963 +val filter : (element -> bool) -> set -> set
  5.2964 +
  5.2965 +val partition : (element -> bool) -> set -> set * set
  5.2966 +
  5.2967 +val count : (element -> bool) -> set -> int
  5.2968 +
  5.2969 +val foldl : (element * 's -> 's) -> 's -> set -> 's
  5.2970 +
  5.2971 +val foldr : (element * 's -> 's) -> 's -> set -> 's
  5.2972 +
  5.2973 +val findl : (element -> bool) -> set -> element option
  5.2974 +
  5.2975 +val findr : (element -> bool) -> set -> element option
  5.2976 +
  5.2977 +val firstl : (element -> 'a option) -> set -> 'a option
  5.2978 +
  5.2979 +val firstr : (element -> 'a option) -> set -> 'a option
  5.2980 +
  5.2981 +val exists : (element -> bool) -> set -> bool
  5.2982 +
  5.2983 +val all : (element -> bool) -> set -> bool
  5.2984 +
  5.2985 +val map : (element -> 'a) -> set -> (element * 'a) list
  5.2986 +
  5.2987 +val transform : (element -> 'a) -> set -> 'a list
  5.2988 +
  5.2989 +val app : (element -> unit) -> set -> unit
  5.2990 +
  5.2991 +val toList : set -> element list
  5.2992 +
  5.2993 +val fromList : element list -> set
  5.2994 +
  5.2995 +val pick : set -> element  (* raises Empty *)
  5.2996 +
  5.2997 +val random : set -> element  (* raises Empty *)
  5.2998 +
  5.2999 +val deletePick : set -> element * set  (* raises Empty *)
  5.3000 +
  5.3001 +val deleteRandom : set -> element * set  (* raises Empty *)
  5.3002 +
  5.3003 +val compare : set * set -> order
  5.3004 +
  5.3005 +val close : (set -> set) -> set -> set
  5.3006 +
  5.3007 +val toString : set -> string
  5.3008 +
  5.3009 +(* ------------------------------------------------------------------------- *)
  5.3010 +(* Iterators over sets                                                       *)
  5.3011 +(* ------------------------------------------------------------------------- *)
  5.3012 +
  5.3013 +type iterator
  5.3014 +
  5.3015 +val mkIterator : set -> iterator option
  5.3016 +
  5.3017 +val mkRevIterator : set -> iterator option
  5.3018 +
  5.3019 +val readIterator : iterator -> element
  5.3020 +
  5.3021 +val advanceIterator : iterator -> iterator option
  5.3022 +
  5.3023 +end
  5.3024 +
  5.3025 +(**** Original file: ElementSet.sml ****)
  5.3026 +
  5.3027 +(* ========================================================================= *)
  5.3028 +(* FINITE SETS WITH A FIXED ELEMENT TYPE                                     *)
  5.3029 +(* Copyright (c) 2004-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.3030 +(* ========================================================================= *)
  5.3031 +
  5.3032 +functor ElementSet (Key : Ordered) :> ElementSet where type element = Key.t =
  5.3033 +struct
  5.3034 +
  5.3035 + open Metis;
  5.3036 +
  5.3037 +type element = Key.t;
  5.3038 +
  5.3039 +(* ------------------------------------------------------------------------- *)
  5.3040 +(* Finite sets                                                               *)
  5.3041 +(* ------------------------------------------------------------------------- *)
  5.3042 +
  5.3043 +type set = Key.t Set.set;
  5.3044 +
  5.3045 +val empty = Set.empty Key.compare;
  5.3046 +
  5.3047 +fun singleton key = Set.singleton Key.compare key;
  5.3048 +
  5.3049 +val null = Set.null;
  5.3050 +
  5.3051 +val size = Set.size;
  5.3052 +
  5.3053 +val member = Set.member;
  5.3054 +
  5.3055 +val add = Set.add;
  5.3056 +
  5.3057 +val addList = Set.addList;
  5.3058 +
  5.3059 +val delete = Set.delete;
  5.3060 +
  5.3061 +val op union = Set.union;
  5.3062 +
  5.3063 +val unionList = Set.unionList;
  5.3064 +
  5.3065 +val intersect = Set.intersect;
  5.3066 +
  5.3067 +val intersectList = Set.intersectList;
  5.3068 +
  5.3069 +val difference = Set.difference;
  5.3070 +
  5.3071 +val symmetricDifference = Set.symmetricDifference;
  5.3072 +
  5.3073 +val disjoint = Set.disjoint;
  5.3074 +
  5.3075 +val op subset = Set.subset;
  5.3076 +
  5.3077 +val equal = Set.equal;
  5.3078 +
  5.3079 +val filter = Set.filter;
  5.3080 +
  5.3081 +val partition = Set.partition;
  5.3082 +
  5.3083 +val count = Set.count;
  5.3084 +
  5.3085 +val foldl = Set.foldl;
  5.3086 +
  5.3087 +val foldr = Set.foldr;
  5.3088 +
  5.3089 +val findl = Set.findl;
  5.3090 +
  5.3091 +val findr = Set.findr;
  5.3092 +
  5.3093 +val firstl = Set.firstl;
  5.3094 +
  5.3095 +val firstr = Set.firstr;
  5.3096 +
  5.3097 +val exists = Set.exists;
  5.3098 +
  5.3099 +val all = Set.all;
  5.3100 +
  5.3101 +val map = Set.map;
  5.3102 +
  5.3103 +val transform = Set.transform;
  5.3104 +
  5.3105 +val app = Set.app;
  5.3106 +
  5.3107 +val toList = Set.toList;
  5.3108 +
  5.3109 +fun fromList l = Set.fromList Key.compare l;
  5.3110 +
  5.3111 +val pick = Set.pick;
  5.3112 +
  5.3113 +val random = Set.random;
  5.3114 +
  5.3115 +val deletePick = Set.deletePick;
  5.3116 +
  5.3117 +val deleteRandom = Set.deleteRandom;
  5.3118 +
  5.3119 +val compare = Set.compare;
  5.3120 +
  5.3121 +val close = Set.close;
  5.3122 +
  5.3123 +val toString = Set.toString;
  5.3124 +
  5.3125 +(* ------------------------------------------------------------------------- *)
  5.3126 +(* Iterators over sets                                                       *)
  5.3127 +(* ------------------------------------------------------------------------- *)
  5.3128 +
  5.3129 +type iterator = Key.t Set.iterator;
  5.3130 +
  5.3131 +val mkIterator = Set.mkIterator;
  5.3132 +
  5.3133 +val mkRevIterator = Set.mkRevIterator;
  5.3134 +
  5.3135 +val readIterator = Set.readIterator;
  5.3136 +
  5.3137 +val advanceIterator = Set.advanceIterator;
  5.3138 +
  5.3139 +end
  5.3140 +
  5.3141 + structure Metis = struct open Metis;
  5.3142 +
  5.3143 +structure IntSet =
  5.3144 +ElementSet (IntOrdered);
  5.3145 +
  5.3146 +structure StringSet =
  5.3147 +ElementSet (StringOrdered);
  5.3148 +
  5.3149 + end;
  5.3150 +
  5.3151 +(**** Original file: Map.sig ****)
  5.3152 +
  5.3153 +(* ========================================================================= *)
  5.3154 +(* FINITE MAPS                                                               *)
  5.3155 +(* Copyright (c) 2004-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.3156 +(* ========================================================================= *)
  5.3157 +
  5.3158 +signature Map =
  5.3159 +sig
  5.3160 +
  5.3161 +(* ------------------------------------------------------------------------- *)
  5.3162 +(* Finite maps                                                               *)
  5.3163 +(* ------------------------------------------------------------------------- *)
  5.3164 +
  5.3165 +type ('key,'a) map
  5.3166 +
  5.3167 +val new : ('key * 'key -> order) -> ('key,'a) map
  5.3168 +
  5.3169 +val null : ('key,'a) map -> bool
  5.3170 +
  5.3171 +val size : ('key,'a) map -> int
  5.3172 +
  5.3173 +val singleton : ('key * 'key -> order) -> 'key * 'a -> ('key,'a) map
  5.3174 +
  5.3175 +val inDomain : 'key -> ('key,'a) map -> bool
  5.3176 +
  5.3177 +val peek : ('key,'a) map -> 'key -> 'a option
  5.3178 +
  5.3179 +val insert : ('key,'a) map -> 'key * 'a -> ('key,'a) map
  5.3180 +
  5.3181 +val insertList : ('key,'a) map -> ('key * 'a) list -> ('key,'a) map
  5.3182 +
  5.3183 +val get : ('key,'a) map -> 'key -> 'a  (* raises Error *)
  5.3184 +
  5.3185 +(* Union and intersect prefer keys in the second map *)
  5.3186 +
  5.3187 +val union :
  5.3188 +    ('a * 'a -> 'a option) -> ('key,'a) map -> ('key,'a) map -> ('key,'a) map
  5.3189 +
  5.3190 +val intersect :
  5.3191 +    ('a * 'a -> 'a option) -> ('key,'a) map -> ('key,'a) map -> ('key,'a) map
  5.3192 +
  5.3193 +val delete : ('key,'a) map -> 'key -> ('key,'a) map  (* raises Error *)
  5.3194 +
  5.3195 +val difference : ('key,'a) map -> ('key,'b) map -> ('key,'a) map
  5.3196 +
  5.3197 +val subsetDomain : ('key,'a) map -> ('key,'a) map -> bool
  5.3198 +
  5.3199 +val equalDomain : ('key,'a) map -> ('key,'a) map -> bool
  5.3200 +
  5.3201 +val mapPartial : ('key * 'a -> 'b option) -> ('key,'a) map -> ('key,'b) map
  5.3202 +
  5.3203 +val filter : ('key * 'a -> bool) -> ('key,'a) map -> ('key,'a) map
  5.3204 +
  5.3205 +val map : ('key * 'a -> 'b) -> ('key,'a) map -> ('key,'b) map
  5.3206 +
  5.3207 +val app : ('key * 'a -> unit) -> ('key,'a) map -> unit
  5.3208 +
  5.3209 +val transform : ('a -> 'b) -> ('key,'a) map -> ('key,'b) map
  5.3210 +
  5.3211 +val foldl : ('key * 'a * 's -> 's) -> 's -> ('key,'a) map -> 's
  5.3212 +
  5.3213 +val foldr : ('key * 'a * 's -> 's) -> 's -> ('key,'a) map -> 's
  5.3214 +
  5.3215 +val findl : ('key * 'a -> bool) -> ('key,'a) map -> ('key * 'a) option
  5.3216 +
  5.3217 +val findr : ('key * 'a -> bool) -> ('key,'a) map -> ('key * 'a) option
  5.3218 +
  5.3219 +val firstl : ('key * 'a -> 'b option) -> ('key,'a) map -> 'b option
  5.3220 +
  5.3221 +val firstr : ('key * 'a -> 'b option) -> ('key,'a) map -> 'b option
  5.3222 +
  5.3223 +val exists : ('key * 'a -> bool) -> ('key,'a) map -> bool
  5.3224 +
  5.3225 +val all : ('key * 'a -> bool) -> ('key,'a) map -> bool
  5.3226 +
  5.3227 +val domain : ('key,'a) map -> 'key list
  5.3228 +
  5.3229 +val toList : ('key,'a) map -> ('key * 'a) list
  5.3230 +
  5.3231 +val fromList : ('key * 'key -> order) -> ('key * 'a) list -> ('key,'a) map
  5.3232 +
  5.3233 +val random : ('key,'a) map -> 'key * 'a  (* raises Empty *)
  5.3234 +
  5.3235 +val compare : ('a * 'a -> order) -> ('key,'a) map * ('key,'a) map -> order
  5.3236 +
  5.3237 +val equal : ('a -> 'a -> bool) -> ('key,'a) map -> ('key,'a) map -> bool
  5.3238 +
  5.3239 +val toString : ('key,'a) map -> string
  5.3240 +
  5.3241 +(* ------------------------------------------------------------------------- *)
  5.3242 +(* Iterators over maps                                                       *)
  5.3243 +(* ------------------------------------------------------------------------- *)
  5.3244 +
  5.3245 +type ('key,'a) iterator
  5.3246 +
  5.3247 +val mkIterator : ('key,'a) map -> ('key,'a) iterator option
  5.3248 +
  5.3249 +val mkRevIterator : ('key,'a) map -> ('key,'a) iterator option
  5.3250 +
  5.3251 +val readIterator : ('key,'a) iterator -> 'key * 'a
  5.3252 +
  5.3253 +val advanceIterator : ('key,'a) iterator -> ('key,'a) iterator option
  5.3254 +
  5.3255 +end
  5.3256 +
  5.3257 +(**** Original file: RandomMap.sml ****)
  5.3258 +
  5.3259 +structure Metis = struct open Metis
  5.3260 +(* Metis-specific ML environment *)
  5.3261 +nonfix ++ -- RL mem union subset;
  5.3262 +val explode = String.explode;
  5.3263 +val implode = String.implode;
  5.3264 +val print = TextIO.print;
  5.3265 +(* ========================================================================= *)
  5.3266 +(* FINITE MAPS IMPLEMENTED WITH RANDOMLY BALANCED TREES                      *)
  5.3267 +(* Copyright (c) 2004-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.3268 +(* ========================================================================= *)
  5.3269 +
  5.3270 +structure RandomMap :> Map =
  5.3271 +struct
  5.3272 +
  5.3273 +exception Bug = Useful.Bug;
  5.3274 +
  5.3275 +exception Error = Useful.Error;
  5.3276 +
  5.3277 +val pointerEqual = Portable.pointerEqual;
  5.3278 +
  5.3279 +val K = Useful.K;
  5.3280 +
  5.3281 +val snd = Useful.snd;
  5.3282 +
  5.3283 +val randomInt = Useful.random;
  5.3284 +
  5.3285 +(* ------------------------------------------------------------------------- *)
  5.3286 +(* Random search trees.                                                      *)
  5.3287 +(* ------------------------------------------------------------------------- *)
  5.3288 +
  5.3289 +datatype ('a,'b) tree =
  5.3290 +    E
  5.3291 +  | T of
  5.3292 +    {size : int,
  5.3293 +     priority : real,
  5.3294 +     left : ('a,'b) tree,
  5.3295 +     key : 'a,
  5.3296 +     value : 'b,
  5.3297 +     right : ('a,'b) tree};
  5.3298 +
  5.3299 +type ('a,'b) node =
  5.3300 +     {size : int,
  5.3301 +      priority : real,
  5.3302 +      left : ('a,'b) tree,
  5.3303 +      key : 'a,
  5.3304 +      value : 'b,
  5.3305 +      right : ('a,'b) tree};
  5.3306 +
  5.3307 +datatype ('a,'b) map = Map of ('a * 'a -> order) * ('a,'b) tree;
  5.3308 +
  5.3309 +(* ------------------------------------------------------------------------- *)
  5.3310 +(* Random priorities.                                                        *)
  5.3311 +(* ------------------------------------------------------------------------- *)
  5.3312 +
  5.3313 +local
  5.3314 +  val randomPriority =
  5.3315 +      let
  5.3316 +        val gen = Random.newgenseed 2.0
  5.3317 +      in
  5.3318 +        fn () => Random.random gen
  5.3319 +      end;
  5.3320 +
  5.3321 +  val priorityOrder = Real.compare;
  5.3322 +in
  5.3323 +  fun treeSingleton (key,value) =
  5.3324 +      T {size = 1, priority = randomPriority (),
  5.3325 +         left = E, key = key, value = value, right = E};
  5.3326 +
  5.3327 +  fun nodePriorityOrder cmp (x1 : ('a,'b) node, x2 : ('a,'b) node) =
  5.3328 +      let
  5.3329 +        val {priority = p1, key = k1, ...} = x1
  5.3330 +        and {priority = p2, key = k2, ...} = x2
  5.3331 +      in
  5.3332 +        case priorityOrder (p1,p2) of
  5.3333 +          LESS => LESS
  5.3334 +        | EQUAL => cmp (k1,k2)
  5.3335 +        | GREATER => GREATER
  5.3336 +      end;
  5.3337 +end;
  5.3338 +
  5.3339 +(* ------------------------------------------------------------------------- *)
  5.3340 +(* Debugging functions.                                                      *)
  5.3341 +(* ------------------------------------------------------------------------- *)
  5.3342 +
  5.3343 +local
  5.3344 +  fun checkSizes E = 0
  5.3345 +    | checkSizes (T {size,left,right,...}) =
  5.3346 +      let
  5.3347 +        val l = checkSizes left
  5.3348 +        and r = checkSizes right
  5.3349 +        val () = if l + 1 + r = size then () else raise Error "wrong size"
  5.3350 +      in
  5.3351 +        size
  5.3352 +      end;
  5.3353 +
  5.3354 +  fun checkSorted _ x E = x
  5.3355 +    | checkSorted cmp x (T {left,key,right,...}) =
  5.3356 +      let
  5.3357 +        val x = checkSorted cmp x left
  5.3358 +        val () =
  5.3359 +            case x of
  5.3360 +              NONE => ()
  5.3361 +            | SOME k =>
  5.3362 +              case cmp (k,key) of
  5.3363 +                LESS => ()
  5.3364 +              | EQUAL => raise Error "duplicate keys"
  5.3365 +              | GREATER => raise Error "unsorted"
  5.3366 +      in
  5.3367 +        checkSorted cmp (SOME key) right
  5.3368 +      end;
  5.3369 +
  5.3370 +  fun checkPriorities _ E = NONE
  5.3371 +    | checkPriorities cmp (T (x as {left,right,...})) =
  5.3372 +      let
  5.3373 +        val () =
  5.3374 +            case checkPriorities cmp left of
  5.3375 +              NONE => ()
  5.3376 +            | SOME l =>
  5.3377 +              case nodePriorityOrder cmp (l,x) of
  5.3378 +                LESS => ()
  5.3379 +              | EQUAL => raise Error "left child has equal key"
  5.3380 +              | GREATER => raise Error "left child has greater priority"
  5.3381 +        val () =
  5.3382 +            case checkPriorities cmp right of
  5.3383 +              NONE => ()
  5.3384 +            | SOME r =>
  5.3385 +              case nodePriorityOrder cmp (r,x) of
  5.3386 +                LESS => ()
  5.3387 +              | EQUAL => raise Error "right child has equal key"
  5.3388 +              | GREATER => raise Error "right child has greater priority"
  5.3389 +      in
  5.3390 +        SOME x
  5.3391 +      end;
  5.3392 +in
  5.3393 +  fun checkWellformed s (m as Map (cmp,tree)) =
  5.3394 +      (let
  5.3395 +         val _ = checkSizes tree
  5.3396 +         val _ = checkSorted cmp NONE tree
  5.3397 +         val _ = checkPriorities cmp tree
  5.3398 +       in
  5.3399 +         m
  5.3400 +       end
  5.3401 +       handle Error err => raise Bug err)
  5.3402 +      handle Bug bug => raise Bug (s ^ "\nRandomMap.checkWellformed: " ^ bug);
  5.3403 +end;
  5.3404 +
  5.3405 +(* ------------------------------------------------------------------------- *)
  5.3406 +(* Basic operations.                                                         *)
  5.3407 +(* ------------------------------------------------------------------------- *)
  5.3408 +
  5.3409 +fun comparison (Map (cmp,_)) = cmp;
  5.3410 +
  5.3411 +fun new cmp = Map (cmp,E);
  5.3412 +
  5.3413 +fun treeSize E = 0
  5.3414 +  | treeSize (T {size = s, ...}) = s;
  5.3415 +
  5.3416 +fun size (Map (_,tree)) = treeSize tree;
  5.3417 +
  5.3418 +fun mkT p l k v r =
  5.3419 +    T {size = treeSize l + 1 + treeSize r, priority = p,
  5.3420 +       left = l, key = k, value = v, right = r};
  5.3421 +
  5.3422 +fun singleton cmp key_value = Map (cmp, treeSingleton key_value);
  5.3423 +
  5.3424 +local
  5.3425 +  fun treePeek cmp E pkey = NONE
  5.3426 +    | treePeek cmp (T {left,key,value,right,...}) pkey =
  5.3427 +      case cmp (pkey,key) of
  5.3428 +        LESS => treePeek cmp left pkey
  5.3429 +      | EQUAL => SOME value
  5.3430 +      | GREATER => treePeek cmp right pkey
  5.3431 +in
  5.3432 +  fun peek (Map (cmp,tree)) key = treePeek cmp tree key;
  5.3433 +end;
  5.3434 +
  5.3435 +(* treeAppend assumes that every element of the first tree is less than *)
  5.3436 +(* every element of the second tree. *)
  5.3437 +
  5.3438 +fun treeAppend _ t1 E = t1
  5.3439 +  | treeAppend _ E t2 = t2
  5.3440 +  | treeAppend cmp (t1 as T x1) (t2 as T x2) =
  5.3441 +    case nodePriorityOrder cmp (x1,x2) of
  5.3442 +      LESS =>
  5.3443 +      let
  5.3444 +        val {priority = p2,
  5.3445 +             left = l2, key = k2, value = v2, right = r2, ...} = x2
  5.3446 +      in
  5.3447 +        mkT p2 (treeAppend cmp t1 l2) k2 v2 r2
  5.3448 +      end
  5.3449 +    | EQUAL => raise Bug "RandomSet.treeAppend: equal keys"
  5.3450 +    | GREATER =>
  5.3451 +      let
  5.3452 +        val {priority = p1,
  5.3453 +             left = l1, key = k1, value = v1, right = r1, ...} = x1
  5.3454 +      in
  5.3455 +        mkT p1 l1 k1 v1 (treeAppend cmp r1 t2)
  5.3456 +      end;
  5.3457 +
  5.3458 +(* nodePartition splits the node into three parts: the keys comparing less *)
  5.3459 +(* than the supplied key, an optional equal key, and the keys comparing *)
  5.3460 +(* greater. *)
  5.3461 +
  5.3462 +local
  5.3463 +  fun mkLeft [] t = t
  5.3464 +    | mkLeft (({priority,left,key,value,...} : ('a,'b) node) :: xs) t =
  5.3465 +      mkLeft xs (mkT priority left key value t);
  5.3466 +
  5.3467 +  fun mkRight [] t = t
  5.3468 +    | mkRight (({priority,key,value,right,...} : ('a,'b) node) :: xs) t =
  5.3469 +      mkRight xs (mkT priority t key value right);
  5.3470 +
  5.3471 +  fun treePart _ _ lefts rights E = (mkLeft lefts E, NONE, mkRight rights E)
  5.3472 +    | treePart cmp pkey lefts rights (T x) = nodePart cmp pkey lefts rights x
  5.3473 +  and nodePart cmp pkey lefts rights (x as {left,key,value,right,...}) =
  5.3474 +      case cmp (pkey,key) of
  5.3475 +        LESS => treePart cmp pkey lefts (x :: rights) left
  5.3476 +      | EQUAL => (mkLeft lefts left, SOME (key,value), mkRight rights right)
  5.3477 +      | GREATER => treePart cmp pkey (x :: lefts) rights right;
  5.3478 +in
  5.3479 +  fun nodePartition cmp x pkey = nodePart cmp pkey [] [] x;
  5.3480 +end;
  5.3481 +
  5.3482 +(* union first calls treeCombineRemove, to combine the values *)
  5.3483 +(* for equal keys into the first map and remove them from the second map. *)
  5.3484 +(* Note that the combined key is always the one from the second map. *)
  5.3485 +
  5.3486 +local
  5.3487 +  fun treeCombineRemove _ _ t1 E = (t1,E)
  5.3488 +    | treeCombineRemove _ _ E t2 = (E,t2)
  5.3489 +    | treeCombineRemove cmp f (t1 as T x1) (t2 as T x2) =
  5.3490 +      let
  5.3491 +        val {priority = p1,
  5.3492 +             left = l1, key = k1, value = v1, right = r1, ...} = x1
  5.3493 +        val (l2,k2_v2,r2) = nodePartition cmp x2 k1
  5.3494 +        val (l1,l2) = treeCombineRemove cmp f l1 l2
  5.3495 +        and (r1,r2) = treeCombineRemove cmp f r1 r2
  5.3496 +      in
  5.3497 +        case k2_v2 of
  5.3498 +          NONE =>
  5.3499 +          if treeSize l2 + treeSize r2 = #size x2 then (t1,t2)
  5.3500 +          else (mkT p1 l1 k1 v1 r1, treeAppend cmp l2 r2)
  5.3501 +        | SOME (k2,v2) =>
  5.3502 +          case f (v1,v2) of
  5.3503 +            NONE => (treeAppend cmp l1 r1, treeAppend cmp l2 r2)
  5.3504 +          | SOME v => (mkT p1 l1 k2 v r1, treeAppend cmp l2 r2)
  5.3505 +      end;
  5.3506 +
  5.3507 +  fun treeUnionDisjoint _ t1 E = t1
  5.3508 +    | treeUnionDisjoint _ E t2 = t2
  5.3509 +    | treeUnionDisjoint cmp (T x1) (T x2) =
  5.3510 +      case nodePriorityOrder cmp (x1,x2) of
  5.3511 +        LESS => nodeUnionDisjoint cmp x2 x1
  5.3512 +      | EQUAL => raise Bug "RandomSet.unionDisjoint: equal keys"
  5.3513 +      | GREATER => nodeUnionDisjoint cmp x1 x2
  5.3514 +  and nodeUnionDisjoint cmp x1 x2 =
  5.3515 +      let
  5.3516 +        val {priority = p1,
  5.3517 +             left = l1, key = k1, value = v1, right = r1, ...} = x1
  5.3518 +        val (l2,_,r2) = nodePartition cmp x2 k1
  5.3519 +        val l = treeUnionDisjoint cmp l1 l2
  5.3520 +        and r = treeUnionDisjoint cmp r1 r2
  5.3521 +      in
  5.3522 +        mkT p1 l k1 v1 r
  5.3523 +      end;
  5.3524 +in
  5.3525 +  fun union f (m1 as Map (cmp,t1)) (Map (_,t2)) =
  5.3526 +      if pointerEqual (t1,t2) then m1
  5.3527 +      else
  5.3528 +        let
  5.3529 +          val (t1,t2) = treeCombineRemove cmp f t1 t2
  5.3530 +        in
  5.3531 +          Map (cmp, treeUnionDisjoint cmp t1 t2)
  5.3532 +        end;
  5.3533 +end;
  5.3534 +
  5.3535 +(*DEBUG
  5.3536 +val union = fn f => fn t1 => fn t2 =>
  5.3537 +    checkWellformed "RandomMap.union: result"
  5.3538 +      (union f (checkWellformed "RandomMap.union: input 1" t1)
  5.3539 +               (checkWellformed "RandomMap.union: input 2" t2));
  5.3540 +*)
  5.3541 +
  5.3542 +(* intersect is a simple case of the union algorithm. *)
  5.3543 +
  5.3544 +local
  5.3545 +  fun treeIntersect _ _ _ E = E
  5.3546 +    | treeIntersect _ _ E _ = E
  5.3547 +    | treeIntersect cmp f (t1 as T x1) (t2 as T x2) =
  5.3548 +      let
  5.3549 +        val {priority = p1,
  5.3550 +             left = l1, key = k1, value = v1, right = r1, ...} = x1
  5.3551 +        val (l2,k2_v2,r2) = nodePartition cmp x2 k1
  5.3552 +        val l = treeIntersect cmp f l1 l2
  5.3553 +        and r = treeIntersect cmp f r1 r2
  5.3554 +      in
  5.3555 +        case k2_v2 of
  5.3556 +          NONE => treeAppend cmp l r
  5.3557 +        | SOME (k2,v2) =>
  5.3558 +          case f (v1,v2) of
  5.3559 +            NONE => treeAppend cmp l r
  5.3560 +          | SOME v => mkT p1 l k2 v r
  5.3561 +      end;
  5.3562 +in
  5.3563 +  fun intersect f (m1 as Map (cmp,t1)) (Map (_,t2)) =
  5.3564 +      if pointerEqual (t1,t2) then m1
  5.3565 +      else Map (cmp, treeIntersect cmp f t1 t2);
  5.3566 +end;
  5.3567 +
  5.3568 +(*DEBUG
  5.3569 +val intersect = fn f => fn t1 => fn t2 =>
  5.3570 +    checkWellformed "RandomMap.intersect: result"
  5.3571 +      (intersect f (checkWellformed "RandomMap.intersect: input 1" t1)
  5.3572 +                   (checkWellformed "RandomMap.intersect: input 2" t2));
  5.3573 +*)
  5.3574 +
  5.3575 +(* delete raises an exception if the supplied key is not found, which *)
  5.3576 +(* makes it simpler to maximize sharing. *)
  5.3577 +
  5.3578 +local
  5.3579 +  fun treeDelete _ E _ = raise Error "RandomMap.delete: element not found"
  5.3580 +    | treeDelete cmp (T {priority,left,key,value,right,...}) dkey =
  5.3581 +      case cmp (dkey,key) of
  5.3582 +        LESS => mkT priority (treeDelete cmp left dkey) key value right
  5.3583 +      | EQUAL => treeAppend cmp left right
  5.3584 +      | GREATER => mkT priority left key value (treeDelete cmp right dkey);
  5.3585 +in
  5.3586 +  fun delete (Map (cmp,tree)) key = Map (cmp, treeDelete cmp tree key);
  5.3587 +end;
  5.3588 + 
  5.3589 +(*DEBUG
  5.3590 +val delete = fn t => fn x =>
  5.3591 +    checkWellformed "RandomMap.delete: result"
  5.3592 +      (delete (checkWellformed "RandomMap.delete: input" t) x);
  5.3593 +*)
  5.3594 +
  5.3595 +(* Set difference on domains *)
  5.3596 +
  5.3597 +local
  5.3598 +  fun treeDifference _ t1 E = t1
  5.3599 +    | treeDifference _ E _ = E
  5.3600 +    | treeDifference cmp (t1 as T x1) (T x2) =
  5.3601 +      let
  5.3602 +        val {size = s1, priority = p1,
  5.3603 +             left = l1, key = k1, value = v1, right = r1} = x1
  5.3604 +        val (l2,k2_v2,r2) = nodePartition cmp x2 k1
  5.3605 +        val l = treeDifference cmp l1 l2
  5.3606 +        and r = treeDifference cmp r1 r2
  5.3607 +      in
  5.3608 +        if Option.isSome k2_v2 then treeAppend cmp l r
  5.3609 +        else if treeSize l + treeSize r + 1 = s1 then t1
  5.3610 +        else mkT p1 l k1 v1 r
  5.3611 +      end;
  5.3612 +in
  5.3613 +  fun difference (Map (cmp,tree1)) (Map (_,tree2)) =
  5.3614 +      Map (cmp, treeDifference cmp tree1 tree2);
  5.3615 +end;
  5.3616 +
  5.3617 +(*DEBUG
  5.3618 +val difference = fn t1 => fn t2 =>
  5.3619 +    checkWellformed "RandomMap.difference: result"
  5.3620 +      (difference (checkWellformed "RandomMap.difference: input 1" t1)
  5.3621 +                  (checkWellformed "RandomMap.difference: input 2" t2));
  5.3622 +*)
  5.3623 +
  5.3624 +(* subsetDomain is mainly used when using maps as sets. *)
  5.3625 +
  5.3626 +local
  5.3627 +  fun treeSubsetDomain _ E _ = true
  5.3628 +    | treeSubsetDomain _ _ E = false
  5.3629 +    | treeSubsetDomain cmp (t1 as T x1) (T x2) =
  5.3630 +      let
  5.3631 +        val {size = s1, left = l1, key = k1, right = r1, ...} = x1
  5.3632 +        and {size = s2, ...} = x2
  5.3633 +      in
  5.3634 +        s1 <= s2 andalso
  5.3635 +        let
  5.3636 +          val (l2,k2_v2,r2) = nodePartition cmp x2 k1
  5.3637 +        in
  5.3638 +          Option.isSome k2_v2 andalso
  5.3639 +          treeSubsetDomain cmp l1 l2 andalso
  5.3640 +          treeSubsetDomain cmp r1 r2
  5.3641 +        end
  5.3642 +      end;
  5.3643 +in
  5.3644 +  fun subsetDomain (Map (cmp,tree1)) (Map (_,tree2)) =
  5.3645 +      pointerEqual (tree1,tree2) orelse
  5.3646 +      treeSubsetDomain cmp tree1 tree2;
  5.3647 +end;
  5.3648 +
  5.3649 +(* Map equality *)
  5.3650 +
  5.3651 +local
  5.3652 +  fun treeEqual _ _ E E = true
  5.3653 +    | treeEqual _ _ E _ = false
  5.3654 +    | treeEqual _ _ _ E = false
  5.3655 +    | treeEqual cmp veq (t1 as T x1) (T x2) =
  5.3656 +      let
  5.3657 +        val {size = s1, left = l1, key = k1, value = v1, right = r1, ...} = x1
  5.3658 +        and {size = s2, ...} = x2
  5.3659 +      in
  5.3660 +        s1 = s2 andalso
  5.3661 +        let
  5.3662 +          val (l2,k2_v2,r2) = nodePartition cmp x2 k1
  5.3663 +        in
  5.3664 +          (case k2_v2 of NONE => false | SOME (_,v2) => veq v1 v2) andalso
  5.3665 +          treeEqual cmp veq l1 l2 andalso
  5.3666 +          treeEqual cmp veq r1 r2
  5.3667 +        end
  5.3668 +      end;
  5.3669 +in
  5.3670 +  fun equal veq (Map (cmp,tree1)) (Map (_,tree2)) =
  5.3671 +      pointerEqual (tree1,tree2) orelse
  5.3672 +      treeEqual cmp veq tree1 tree2;
  5.3673 +end;
  5.3674 +
  5.3675 +(* mapPartial is the basic function for preserving the tree structure. *)
  5.3676 +(* It applies the argument function to the elements *in order*. *)
  5.3677 +
  5.3678 +local
  5.3679 +  fun treeMapPartial cmp _ E = E
  5.3680 +    | treeMapPartial cmp f (T {priority,left,key,value,right,...}) =
  5.3681 +      let
  5.3682 +        val left = treeMapPartial cmp f left
  5.3683 +        and value' = f (key,value)
  5.3684 +        and right = treeMapPartial cmp f right
  5.3685 +      in
  5.3686 +        case value' of
  5.3687 +          NONE => treeAppend cmp left right
  5.3688 +        | SOME value => mkT priority left key value right
  5.3689 +      end;
  5.3690 +in
  5.3691 +  fun mapPartial f (Map (cmp,tree)) = Map (cmp, treeMapPartial cmp f tree);
  5.3692 +end;
  5.3693 +
  5.3694 +(* map is a primitive function for efficiency reasons. *)
  5.3695 +(* It also applies the argument function to the elements *in order*. *)
  5.3696 +
  5.3697 +local
  5.3698 +  fun treeMap _ E = E
  5.3699 +    | treeMap f (T {size,priority,left,key,value,right}) =
  5.3700 +      let
  5.3701 +        val left = treeMap f left
  5.3702 +        and value = f (key,value)
  5.3703 +        and right = treeMap f right
  5.3704 +      in
  5.3705 +        T {size = size, priority = priority, left = left,
  5.3706 +           key = key, value = value, right = right}
  5.3707 +      end;
  5.3708 +in
  5.3709 +  fun map f (Map (cmp,tree)) = Map (cmp, treeMap f tree);
  5.3710 +end;
  5.3711 +
  5.3712 +(* nth picks the nth smallest key/value (counting from 0). *)
  5.3713 +
  5.3714 +local
  5.3715 +  fun treeNth E _ = raise Subscript
  5.3716 +    | treeNth (T {left,key,value,right,...}) n =
  5.3717 +      let
  5.3718 +        val k = treeSize left
  5.3719 +      in
  5.3720 +        if n = k then (key,value)
  5.3721 +        else if n < k then treeNth left n
  5.3722 +        else treeNth right (n - (k + 1))
  5.3723 +      end;
  5.3724 +in
  5.3725 +  fun nth (Map (_,tree)) n = treeNth tree n;
  5.3726 +end;
  5.3727 +
  5.3728 +(* ------------------------------------------------------------------------- *)
  5.3729 +(* Iterators.                                                                *)
  5.3730 +(* ------------------------------------------------------------------------- *)
  5.3731 +
  5.3732 +fun leftSpine E acc = acc
  5.3733 +  | leftSpine (t as T {left,...}) acc = leftSpine left (t :: acc);
  5.3734 +
  5.3735 +fun rightSpine E acc = acc
  5.3736 +  | rightSpine (t as T {right,...}) acc = rightSpine right (t :: acc);
  5.3737 +
  5.3738 +datatype ('key,'a) iterator =
  5.3739 +    LR of ('key * 'a) * ('key,'a) tree * ('key,'a) tree list
  5.3740 +  | RL of ('key * 'a) * ('key,'a) tree * ('key,'a) tree list;
  5.3741 +
  5.3742 +fun mkLR [] = NONE
  5.3743 +  | mkLR (T {key,value,right,...} :: l) = SOME (LR ((key,value),right,l))
  5.3744 +  | mkLR (E :: _) = raise Bug "RandomMap.mkLR";
  5.3745 +
  5.3746 +fun mkRL [] = NONE
  5.3747 +  | mkRL (T {key,value,left,...} :: l) = SOME (RL ((key,value),left,l))
  5.3748 +  | mkRL (E :: _) = raise Bug "RandomMap.mkRL";
  5.3749 +
  5.3750 +fun mkIterator (Map (_,tree)) = mkLR (leftSpine tree []);
  5.3751 +
  5.3752 +fun mkRevIterator (Map (_,tree)) = mkRL (rightSpine tree []);
  5.3753 +
  5.3754 +fun readIterator (LR (key_value,_,_)) = key_value
  5.3755 +  | readIterator (RL (key_value,_,_)) = key_value;
  5.3756 +
  5.3757 +fun advanceIterator (LR (_,next,l)) = mkLR (leftSpine next l)
  5.3758 +  | advanceIterator (RL (_,next,l)) = mkRL (rightSpine next l);
  5.3759 +
  5.3760 +(* ------------------------------------------------------------------------- *)
  5.3761 +(* Derived operations.                                                       *)
  5.3762 +(* ------------------------------------------------------------------------- *)
  5.3763 +
  5.3764 +fun null m = size m = 0;
  5.3765 +
  5.3766 +fun get m key =
  5.3767 +    case peek m key of
  5.3768 +      NONE => raise Error "RandomMap.get: element not found"
  5.3769 +    | SOME value => value;
  5.3770 +
  5.3771 +fun inDomain key m = Option.isSome (peek m key);
  5.3772 +
  5.3773 +fun insert m key_value =
  5.3774 +    union (SOME o snd) m (singleton (comparison m) key_value);
  5.3775 +
  5.3776 +(*DEBUG
  5.3777 +val insert = fn m => fn x =>
  5.3778 +    checkWellformed "RandomMap.insert: result"
  5.3779 +      (insert (checkWellformed "RandomMap.insert: input" m) x);
  5.3780 +*)
  5.3781 +
  5.3782 +local
  5.3783 +  fun fold _ NONE acc = acc
  5.3784 +    | fold f (SOME iter) acc =
  5.3785 +      let
  5.3786 +        val (key,value) = readIterator iter
  5.3787 +      in
  5.3788 +        fold f (advanceIterator iter) (f (key,value,acc))
  5.3789 +      end;
  5.3790 +in
  5.3791 +  fun foldl f b m = fold f (mkIterator m) b;
  5.3792 +
  5.3793 +  fun foldr f b m = fold f (mkRevIterator m) b;
  5.3794 +end;
  5.3795 +
  5.3796 +local
  5.3797 +  fun find _ NONE = NONE
  5.3798 +    | find pred (SOME iter) =
  5.3799 +      let
  5.3800 +        val key_value = readIterator iter
  5.3801 +      in
  5.3802 +        if pred key_value then SOME key_value
  5.3803 +        else find pred (advanceIterator iter)
  5.3804 +      end;
  5.3805 +in
  5.3806 +  fun findl p m = find p (mkIterator m);
  5.3807 +
  5.3808 +  fun findr p m = find p (mkRevIterator m);
  5.3809 +end;
  5.3810 +
  5.3811 +local
  5.3812 +  fun first _ NONE = NONE
  5.3813 +    | first f (SOME iter) =
  5.3814 +      let
  5.3815 +        val key_value = readIterator iter
  5.3816 +      in
  5.3817 +        case f key_value of
  5.3818 +          NONE => first f (advanceIterator iter)
  5.3819 +        | s => s
  5.3820 +      end;
  5.3821 +in
  5.3822 +  fun firstl f m = first f (mkIterator m);
  5.3823 +
  5.3824 +  fun firstr f m = first f (mkRevIterator m);
  5.3825 +end;
  5.3826 +
  5.3827 +fun fromList cmp l = List.foldl (fn (k_v,m) => insert m k_v) (new cmp) l;
  5.3828 +
  5.3829 +fun insertList m l = union (SOME o snd) m (fromList (comparison m) l);
  5.3830 +
  5.3831 +fun filter p =
  5.3832 +    let
  5.3833 +      fun f (key_value as (_,value)) =
  5.3834 +          if p key_value then SOME value else NONE
  5.3835 +    in
  5.3836 +      mapPartial f
  5.3837 +    end;
  5.3838 +
  5.3839 +fun app f m = foldl (fn (key,value,()) => f (key,value)) () m;
  5.3840 +
  5.3841 +fun transform f = map (fn (_,value) => f value);
  5.3842 +
  5.3843 +fun toList m = foldr (fn (key,value,l) => (key,value) :: l) [] m;
  5.3844 +
  5.3845 +fun domain m = foldr (fn (key,_,l) => key :: l) [] m;
  5.3846 +
  5.3847 +fun exists p m = Option.isSome (findl p m);
  5.3848 +
  5.3849 +fun all p m = not (exists (not o p) m);
  5.3850 +
  5.3851 +fun random m = case size m of 0 => raise Empty | n => nth m (randomInt n);
  5.3852 +
  5.3853 +local
  5.3854 +  fun iterCompare _ _ NONE NONE = EQUAL
  5.3855 +    | iterCompare _ _ NONE (SOME _) = LESS
  5.3856 +    | iterCompare _ _ (SOME _) NONE = GREATER
  5.3857 +    | iterCompare kcmp vcmp (SOME i1) (SOME i2) =
  5.3858 +      keyIterCompare kcmp vcmp (readIterator i1) (readIterator i2) i1 i2
  5.3859 +
  5.3860 +  and keyIterCompare kcmp vcmp (k1,v1) (k2,v2) i1 i2 =
  5.3861 +      case kcmp (k1,k2) of
  5.3862 +        LESS => LESS
  5.3863 +      | EQUAL =>
  5.3864 +        (case vcmp (v1,v2) of
  5.3865 +           LESS => LESS
  5.3866 +         | EQUAL =>
  5.3867 +           iterCompare kcmp vcmp (advanceIterator i1) (advanceIterator i2)
  5.3868 +         | GREATER => GREATER)
  5.3869 +      | GREATER => GREATER;
  5.3870 +in
  5.3871 +  fun compare vcmp (m1,m2) =
  5.3872 +      if pointerEqual (m1,m2) then EQUAL
  5.3873 +      else
  5.3874 +        case Int.compare (size m1, size m2) of
  5.3875 +          LESS => LESS
  5.3876 +        | EQUAL =>
  5.3877 +          iterCompare (comparison m1) vcmp (mkIterator m1) (mkIterator m2)
  5.3878 +        | GREATER => GREATER;
  5.3879 +end;
  5.3880 +
  5.3881 +fun equalDomain m1 m2 = equal (K (K true)) m1 m2;
  5.3882 +
  5.3883 +fun toString m = "<" ^ (if null m then "" else Int.toString (size m)) ^ ">";
  5.3884 +
  5.3885 +end
  5.3886 +end;
  5.3887 +
  5.3888 +(**** Original file: Map.sml ****)
  5.3889 +
  5.3890 +structure Metis = struct open Metis
  5.3891 +(* Metis-specific ML environment *)
  5.3892 +nonfix ++ -- RL mem union subset;
  5.3893 +val explode = String.explode;
  5.3894 +val implode = String.implode;
  5.3895 +val print = TextIO.print;
  5.3896 +(* ========================================================================= *)
  5.3897 +(* FINITE MAPS                                                               *)
  5.3898 +(* Copyright (c) 2004-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.3899 +(* ========================================================================= *)
  5.3900 +
  5.3901 +structure Map = RandomMap;
  5.3902 +end;
  5.3903 +
  5.3904 +(**** Original file: KeyMap.sig ****)
  5.3905 +
  5.3906 +(* ========================================================================= *)
  5.3907 +(* FINITE MAPS WITH A FIXED KEY TYPE                                         *)
  5.3908 +(* Copyright (c) 2004-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.3909 +(* ========================================================================= *)
  5.3910 +
  5.3911 +signature KeyMap =
  5.3912 +sig
  5.3913 +
  5.3914 +type key
  5.3915 +
  5.3916 +(* ------------------------------------------------------------------------- *)
  5.3917 +(* Finite maps                                                               *)
  5.3918 +(* ------------------------------------------------------------------------- *)
  5.3919 +
  5.3920 +type 'a map
  5.3921 +
  5.3922 +val new : unit -> 'a map
  5.3923 +
  5.3924 +val null : 'a map -> bool
  5.3925 +
  5.3926 +val size : 'a map -> int
  5.3927 +
  5.3928 +val singleton : key * 'a -> 'a map
  5.3929 +
  5.3930 +val inDomain : key -> 'a map -> bool
  5.3931 +
  5.3932 +val peek : 'a map -> key -> 'a option
  5.3933 +
  5.3934 +val insert : 'a map -> key * 'a -> 'a map
  5.3935 +
  5.3936 +val insertList : 'a map -> (key * 'a) list -> 'a map
  5.3937 +
  5.3938 +val get : 'a map -> key -> 'a  (* raises Error *)
  5.3939 +
  5.3940 +(* Union and intersect prefer keys in the second map *)
  5.3941 +
  5.3942 +val union : ('a * 'a -> 'a option) -> 'a map -> 'a map -> 'a map
  5.3943 +
  5.3944 +val intersect : ('a * 'a -> 'a option) -> 'a map -> 'a map -> 'a map
  5.3945 +
  5.3946 +val delete : 'a map -> key -> 'a map  (* raises Error *)
  5.3947 +
  5.3948 +val difference : 'a map -> 'a map -> 'a map
  5.3949 +
  5.3950 +val subsetDomain : 'a map -> 'a map -> bool
  5.3951 +
  5.3952 +val equalDomain : 'a map -> 'a map -> bool
  5.3953 +
  5.3954 +val mapPartial : (key * 'a -> 'b option) -> 'a map -> 'b map
  5.3955 +
  5.3956 +val filter : (key * 'a -> bool) -> 'a map -> 'a map
  5.3957 +
  5.3958 +val map : (key * 'a -> 'b) -> 'a map -> 'b map
  5.3959 +
  5.3960 +val app : (key * 'a -> unit) -> 'a map -> unit
  5.3961 +
  5.3962 +val transform : ('a -> 'b) -> 'a map -> 'b map
  5.3963 +
  5.3964 +val foldl : (key * 'a * 's -> 's) -> 's -> 'a map -> 's
  5.3965 +
  5.3966 +val foldr : (key * 'a * 's -> 's) -> 's -> 'a map -> 's
  5.3967 +
  5.3968 +val findl : (key * 'a -> bool) -> 'a map -> (key * 'a) option
  5.3969 +
  5.3970 +val findr : (key * 'a -> bool) -> 'a map -> (key * 'a) option
  5.3971 +
  5.3972 +val firstl : (key * 'a -> 'b option) -> 'a map -> 'b option
  5.3973 +
  5.3974 +val firstr : (key * 'a -> 'b option) -> 'a map -> 'b option
  5.3975 +
  5.3976 +val exists : (key * 'a -> bool) -> 'a map -> bool
  5.3977 +
  5.3978 +val all : (key * 'a -> bool) -> 'a map -> bool
  5.3979 +
  5.3980 +val domain : 'a map -> key list
  5.3981 +
  5.3982 +val toList : 'a map -> (key * 'a) list
  5.3983 +
  5.3984 +val fromList : (key * 'a) list -> 'a map
  5.3985 +
  5.3986 +val compare : ('a * 'a -> order) -> 'a map * 'a map -> order
  5.3987 +
  5.3988 +val equal : ('a -> 'a -> bool) -> 'a map -> 'a map -> bool
  5.3989 +
  5.3990 +val random : 'a map -> key * 'a  (* raises Empty *)
  5.3991 +
  5.3992 +val toString : 'a map -> string
  5.3993 +
  5.3994 +(* ------------------------------------------------------------------------- *)
  5.3995 +(* Iterators over maps                                                       *)
  5.3996 +(* ------------------------------------------------------------------------- *)
  5.3997 +
  5.3998 +type 'a iterator
  5.3999 +
  5.4000 +val mkIterator : 'a map -> 'a iterator option
  5.4001 +
  5.4002 +val mkRevIterator : 'a map -> 'a iterator option
  5.4003 +
  5.4004 +val readIterator : 'a iterator -> key * 'a
  5.4005 +
  5.4006 +val advanceIterator : 'a iterator -> 'a iterator option
  5.4007 +
  5.4008 +end
  5.4009 +
  5.4010 +(**** Original file: KeyMap.sml ****)
  5.4011 +
  5.4012 +(* ========================================================================= *)
  5.4013 +(* FINITE MAPS WITH A FIXED KEY TYPE                                         *)
  5.4014 +(* Copyright (c) 2004-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.4015 +(* ========================================================================= *)
  5.4016 +
  5.4017 +functor KeyMap (Key : Ordered) :> KeyMap where type key = Key.t =
  5.4018 +struct
  5.4019 +
  5.4020 + open Metis;
  5.4021 +
  5.4022 +type key = Key.t;
  5.4023 +
  5.4024 +(* ------------------------------------------------------------------------- *)
  5.4025 +(* Finite maps                                                               *)
  5.4026 +(* ------------------------------------------------------------------------- *)
  5.4027 +
  5.4028 +type 'a map = (Key.t,'a) Map.map;
  5.4029 +
  5.4030 +fun new () = Map.new Key.compare;
  5.4031 +
  5.4032 +val null = Map.null;
  5.4033 +
  5.4034 +val size = Map.size;
  5.4035 +
  5.4036 +fun singleton key_value = Map.singleton Key.compare key_value;
  5.4037 +
  5.4038 +val inDomain = Map.inDomain;
  5.4039 +
  5.4040 +val peek = Map.peek;
  5.4041 +
  5.4042 +val insert = Map.insert;
  5.4043 +
  5.4044 +val insertList = Map.insertList;
  5.4045 +
  5.4046 +val get = Map.get;
  5.4047 +
  5.4048 +(* Both op union and intersect prefer keys in the second map *)
  5.4049 +
  5.4050 +val op union = Map.union;
  5.4051 +
  5.4052 +val intersect = Map.intersect;
  5.4053 +
  5.4054 +val delete = Map.delete;
  5.4055 +
  5.4056 +val difference = Map.difference;
  5.4057 +
  5.4058 +val subsetDomain = Map.subsetDomain;
  5.4059 +
  5.4060 +val equalDomain = Map.equalDomain;
  5.4061 +
  5.4062 +val mapPartial = Map.mapPartial;
  5.4063 +
  5.4064 +val filter = Map.filter;
  5.4065 +
  5.4066 +val map = Map.map;
  5.4067 +
  5.4068 +val app = Map.app;
  5.4069 +
  5.4070 +val transform = Map.transform;
  5.4071 +
  5.4072 +val foldl = Map.foldl;
  5.4073 +
  5.4074 +val foldr = Map.foldr;
  5.4075 +
  5.4076 +val findl = Map.findl;
  5.4077 +
  5.4078 +val findr = Map.findr;
  5.4079 +
  5.4080 +val firstl = Map.firstl;
  5.4081 +
  5.4082 +val firstr = Map.firstr;
  5.4083 +
  5.4084 +val exists = Map.exists;
  5.4085 +
  5.4086 +val all = Map.all;
  5.4087 +
  5.4088 +val domain = Map.domain;
  5.4089 +
  5.4090 +val toList = Map.toList;
  5.4091 +
  5.4092 +fun fromList l = Map.fromList Key.compare l;
  5.4093 +
  5.4094 +val compare = Map.compare;
  5.4095 +
  5.4096 +val equal = Map.equal;
  5.4097 +
  5.4098 +val random = Map.random;
  5.4099 +
  5.4100 +val toString = Map.toString;
  5.4101 +
  5.4102 +(* ------------------------------------------------------------------------- *)
  5.4103 +(* Iterators over maps                                                       *)
  5.4104 +(* ------------------------------------------------------------------------- *)
  5.4105 +
  5.4106 +type 'a iterator = (Key.t,'a) Map.iterator;
  5.4107 +
  5.4108 +val mkIterator = Map.mkIterator;
  5.4109 +
  5.4110 +val mkRevIterator = Map.mkRevIterator;
  5.4111 +
  5.4112 +val readIterator = Map.readIterator;
  5.4113 +
  5.4114 +val advanceIterator = Map.advanceIterator;
  5.4115 +
  5.4116 +end
  5.4117 +
  5.4118 + structure Metis = struct open Metis
  5.4119 +
  5.4120 +structure IntMap =
  5.4121 +KeyMap (IntOrdered);
  5.4122 +
  5.4123 +structure StringMap =
  5.4124 +KeyMap (StringOrdered);
  5.4125 +
  5.4126 + end;
  5.4127 +
  5.4128 +(**** Original file: Sharing.sig ****)
  5.4129 +
  5.4130 +(* ========================================================================= *)
  5.4131 +(* PRESERVING SHARING OF ML VALUES                                           *)
  5.4132 +(* Copyright (c) 2005-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.4133 +(* ========================================================================= *)
  5.4134 +
  5.4135 +signature Sharing =
  5.4136 +sig
  5.4137 +
  5.4138 +(* ------------------------------------------------------------------------- *)
  5.4139 +(* Pointer equality.                                                         *)
  5.4140 +(* ------------------------------------------------------------------------- *)
  5.4141 +
  5.4142 +val pointerEqual : 'a * 'a -> bool
  5.4143 +
  5.4144 +(* ------------------------------------------------------------------------- *)
  5.4145 +(* List operations.                                                          *)
  5.4146 +(* ------------------------------------------------------------------------- *)
  5.4147 +
  5.4148 +val map : ('a -> 'a) -> 'a list -> 'a list
  5.4149 +
  5.4150 +val updateNth : int * 'a -> 'a list -> 'a list
  5.4151 +
  5.4152 +val setify : ''a list -> ''a list
  5.4153 +
  5.4154 +(* ------------------------------------------------------------------------- *)
  5.4155 +(* Function caching.                                                         *)
  5.4156 +(* ------------------------------------------------------------------------- *)
  5.4157 +
  5.4158 +val cache : ('a * 'a -> order) -> ('a -> 'b) -> 'a -> 'b
  5.4159 +
  5.4160 +(* ------------------------------------------------------------------------- *)
  5.4161 +(* Hash consing.                                                             *)
  5.4162 +(* ------------------------------------------------------------------------- *)
  5.4163 +
  5.4164 +val hashCons : ('a * 'a -> order) -> 'a -> 'a
  5.4165 +
  5.4166 +end
  5.4167 +
  5.4168 +(**** Original file: Sharing.sml ****)
  5.4169 +
  5.4170 +structure Metis = struct open Metis
  5.4171 +(* Metis-specific ML environment *)
  5.4172 +nonfix ++ -- RL mem union subset;
  5.4173 +val explode = String.explode;
  5.4174 +val implode = String.implode;
  5.4175 +val print = TextIO.print;
  5.4176 +(* ========================================================================= *)
  5.4177 +(* PRESERVING SHARING OF ML VALUES                                           *)
  5.4178 +(* Copyright (c) 2005-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.4179 +(* ========================================================================= *)
  5.4180 +
  5.4181 +structure Sharing :> Sharing =
  5.4182 +struct
  5.4183 +
  5.4184 +infix ==
  5.4185 +
  5.4186 +(* ------------------------------------------------------------------------- *)
  5.4187 +(* Pointer equality.                                                         *)
  5.4188 +(* ------------------------------------------------------------------------- *)
  5.4189 +
  5.4190 +val pointerEqual = Portable.pointerEqual;
  5.4191 +
  5.4192 +val op== = pointerEqual;
  5.4193 +
  5.4194 +(* ------------------------------------------------------------------------- *)
  5.4195 +(* List operations.                                                          *)
  5.4196 +(* ------------------------------------------------------------------------- *)
  5.4197 +
  5.4198 +fun map f =
  5.4199 +    let
  5.4200 +      fun m _ a_b [] = List.revAppend a_b
  5.4201 +        | m ys a_b (x :: xs) =
  5.4202 +          let
  5.4203 +            val y = f x
  5.4204 +            val ys = y :: ys
  5.4205 +          in
  5.4206 +            m ys (if x == y then a_b else (ys,xs)) xs
  5.4207 +          end
  5.4208 +    in
  5.4209 +      fn l => m [] ([],l) l
  5.4210 +    end;
  5.4211 +
  5.4212 +fun updateNth (n,x) l =
  5.4213 +    let
  5.4214 +      val (a,b) = Useful.revDivide l n
  5.4215 +    in
  5.4216 +      case b of
  5.4217 +        [] => raise Subscript
  5.4218 +      | h :: t => if x == h then l else List.revAppend (a, x :: t)
  5.4219 +    end;
  5.4220 +
  5.4221 +fun setify l =
  5.4222 +    let
  5.4223 +      val l' = Useful.setify l
  5.4224 +    in
  5.4225 +      if length l' = length l then l else l'
  5.4226 +    end;
  5.4227 +
  5.4228 +(* ------------------------------------------------------------------------- *)
  5.4229 +(* Function caching.                                                         *)
  5.4230 +(* ------------------------------------------------------------------------- *)
  5.4231 +
  5.4232 +fun cache cmp f =
  5.4233 +    let
  5.4234 +      val cache = ref (Map.new cmp)
  5.4235 +    in
  5.4236 +      fn a =>
  5.4237 +         case Map.peek (!cache) a of
  5.4238 +           SOME b => b
  5.4239 +         | NONE =>
  5.4240 +           let
  5.4241 +             val b = f a
  5.4242 +             val () = cache := Map.insert (!cache) (a,b)
  5.4243 +           in
  5.4244 +             b
  5.4245 +           end
  5.4246 +    end;
  5.4247 +
  5.4248 +(* ------------------------------------------------------------------------- *)
  5.4249 +(* Hash consing.                                                             *)
  5.4250 +(* ------------------------------------------------------------------------- *)
  5.4251 +
  5.4252 +fun hashCons cmp = cache cmp Useful.I;
  5.4253 +
  5.4254 +end
  5.4255 +end;
  5.4256 +
  5.4257 +(**** Original file: Stream.sig ****)
  5.4258 +
  5.4259 +(* ========================================================================= *)
  5.4260 +(* A POSSIBLY-INFINITE STREAM DATATYPE FOR ML                                *)
  5.4261 +(* Copyright (c) 2001-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.4262 +(* ========================================================================= *)
  5.4263 +
  5.4264 +signature Stream =
  5.4265 +sig
  5.4266 +
  5.4267 +(* ------------------------------------------------------------------------- *)
  5.4268 +(* The stream type                                                           *)
  5.4269 +(* ------------------------------------------------------------------------- *)
  5.4270 +
  5.4271 +datatype 'a stream = NIL | CONS of 'a * (unit -> 'a stream)
  5.4272 +
  5.4273 +(* If you're wondering how to create an infinite stream: *)
  5.4274 +(* val stream4 = let fun s4 () = Metis.Stream.CONS (4,s4) in s4 () end; *)
  5.4275 +
  5.4276 +(* ------------------------------------------------------------------------- *)
  5.4277 +(* Stream constructors                                                       *)
  5.4278 +(* ------------------------------------------------------------------------- *)
  5.4279 +
  5.4280 +val repeat : 'a -> 'a stream
  5.4281 +
  5.4282 +val count : int -> int stream
  5.4283 +
  5.4284 +val funpows : ('a -> 'a) -> 'a -> 'a stream
  5.4285 +
  5.4286 +(* ------------------------------------------------------------------------- *)
  5.4287 +(* Stream versions of standard list operations: these should all terminate   *)
  5.4288 +(* ------------------------------------------------------------------------- *)
  5.4289 +
  5.4290 +val cons : 'a -> (unit -> 'a stream) -> 'a stream
  5.4291 +
  5.4292 +val null : 'a stream -> bool
  5.4293 +
  5.4294 +val hd : 'a stream -> 'a  (* raises Empty *)
  5.4295 +
  5.4296 +val tl : 'a stream -> 'a stream  (* raises Empty *)
  5.4297 +
  5.4298 +val hdTl : 'a stream -> 'a * 'a stream  (* raises Empty *)
  5.4299 +
  5.4300 +val singleton : 'a -> 'a stream
  5.4301 +
  5.4302 +val append : 'a stream -> (unit -> 'a stream) -> 'a stream
  5.4303 +
  5.4304 +val map : ('a -> 'b) -> 'a stream -> 'b stream
  5.4305 +
  5.4306 +val maps : ('a -> 's -> 'b * 's) -> 's -> 'a stream -> 'b stream
  5.4307 +
  5.4308 +val zipwith : ('a -> 'b -> 'c) -> 'a stream -> 'b stream -> 'c stream
  5.4309 +
  5.4310 +val zip : 'a stream -> 'b stream -> ('a * 'b) stream
  5.4311 +
  5.4312 +val take : int -> 'a stream -> 'a stream  (* raises Subscript *)
  5.4313 +
  5.4314 +val drop : int -> 'a stream -> 'a stream  (* raises Subscript *)
  5.4315 +
  5.4316 +(* ------------------------------------------------------------------------- *)
  5.4317 +(* Stream versions of standard list operations: these might not terminate    *)
  5.4318 +(* ------------------------------------------------------------------------- *)
  5.4319 +
  5.4320 +val length : 'a stream -> int
  5.4321 +
  5.4322 +val exists : ('a -> bool) -> 'a stream -> bool
  5.4323 +
  5.4324 +val all : ('a -> bool) -> 'a stream -> bool
  5.4325 +
  5.4326 +val filter : ('a -> bool) -> 'a stream -> 'a stream
  5.4327 +
  5.4328 +val foldl : ('a * 's -> 's) -> 's -> 'a stream -> 's
  5.4329 +
  5.4330 +val concat : 'a stream stream -> 'a stream
  5.4331 +
  5.4332 +val mapPartial : ('a -> 'b option) -> 'a stream -> 'b stream
  5.4333 +
  5.4334 +val mapsPartial : ('a -> 's -> 'b option * 's) -> 's -> 'a stream -> 'b stream
  5.4335 +
  5.4336 +(* ------------------------------------------------------------------------- *)
  5.4337 +(* Stream operations                                                         *)
  5.4338 +(* ------------------------------------------------------------------------- *)
  5.4339 +
  5.4340 +val memoize : 'a stream -> 'a stream
  5.4341 +
  5.4342 +val toList : 'a stream -> 'a list
  5.4343 +
  5.4344 +val fromList : 'a list -> 'a stream
  5.4345 +
  5.4346 +val toTextFile : {filename : string} -> string stream -> unit
  5.4347 +
  5.4348 +val fromTextFile : {filename : string} -> string stream  (* line by line *)
  5.4349 +
  5.4350 +end
  5.4351 +
  5.4352 +(**** Original file: Stream.sml ****)
  5.4353 +
  5.4354 +structure Metis = struct open Metis
  5.4355 +(* Metis-specific ML environment *)
  5.4356 +nonfix ++ -- RL mem union subset;
  5.4357 +val explode = String.explode;
  5.4358 +val implode = String.implode;
  5.4359 +val print = TextIO.print;
  5.4360 +(* ========================================================================= *)
  5.4361 +(* A POSSIBLY-INFINITE STREAM DATATYPE FOR ML                                *)
  5.4362 +(* Copyright (c) 2001-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.4363 +(* ========================================================================= *)
  5.4364 +
  5.4365 +structure Stream :> Stream =
  5.4366 +struct
  5.4367 +
  5.4368 +val K = Useful.K;
  5.4369 +
  5.4370 +val pair = Useful.pair;
  5.4371 +
  5.4372 +val funpow = Useful.funpow;
  5.4373 +
  5.4374 +(* ------------------------------------------------------------------------- *)
  5.4375 +(* The datatype declaration encapsulates all the primitive operations        *)
  5.4376 +(* ------------------------------------------------------------------------- *)
  5.4377 +
  5.4378 +datatype 'a stream =
  5.4379 +    NIL
  5.4380 +  | CONS of 'a * (unit -> 'a stream);
  5.4381 +
  5.4382 +(* ------------------------------------------------------------------------- *)
  5.4383 +(* Stream constructors                                                       *)
  5.4384 +(* ------------------------------------------------------------------------- *)
  5.4385 +
  5.4386 +fun repeat x = let fun rep () = CONS (x,rep) in rep () end;
  5.4387 +
  5.4388 +fun count n = CONS (n, fn () => count (n + 1));
  5.4389 +
  5.4390 +fun funpows f x = CONS (x, fn () => funpows f (f x));
  5.4391 +
  5.4392 +(* ------------------------------------------------------------------------- *)
  5.4393 +(* Stream versions of standard list operations: these should all terminate   *)
  5.4394 +(* ------------------------------------------------------------------------- *)
  5.4395 +
  5.4396 +fun cons h t = CONS (h,t);
  5.4397 +
  5.4398 +fun null NIL = true | null (CONS _) = false;
  5.4399 +
  5.4400 +fun hd NIL = raise Empty
  5.4401 +  | hd (CONS (h,_)) = h;
  5.4402 +
  5.4403 +fun tl NIL = raise Empty
  5.4404 +  | tl (CONS (_,t)) = t ();
  5.4405 +
  5.4406 +fun hdTl s = (hd s, tl s);
  5.4407 +
  5.4408 +fun singleton s = CONS (s, K NIL);
  5.4409 +
  5.4410 +fun append NIL s = s ()
  5.4411 +  | append (CONS (h,t)) s = CONS (h, fn () => append (t ()) s);
  5.4412 +
  5.4413 +fun map f =
  5.4414 +    let
  5.4415 +      fun m NIL = NIL
  5.4416 +        | m (CONS (h, t)) = CONS (f h, fn () => m (t ()))
  5.4417 +    in
  5.4418 +      m
  5.4419 +    end;
  5.4420 +
  5.4421 +fun maps f =
  5.4422 +    let
  5.4423 +      fun mm _ NIL = NIL
  5.4424 +        | mm s (CONS (x, xs)) =
  5.4425 +          let
  5.4426 +            val (y, s') = f x s
  5.4427 +          in
  5.4428 +            CONS (y, fn () => mm s' (xs ()))
  5.4429 +          end
  5.4430 +    in
  5.4431 +      mm
  5.4432 +    end;
  5.4433 +
  5.4434 +fun zipwith f =
  5.4435 +    let
  5.4436 +      fun z NIL _ = NIL
  5.4437 +        | z _ NIL = NIL
  5.4438 +        | z (CONS (x,xs)) (CONS (y,ys)) =
  5.4439 +          CONS (f x y, fn () => z (xs ()) (ys ()))
  5.4440 +    in
  5.4441 +      z
  5.4442 +    end;
  5.4443 +
  5.4444 +fun zip s t = zipwith pair s t;
  5.4445 +
  5.4446 +fun take 0 _ = NIL
  5.4447 +  | take n NIL = raise Subscript
  5.4448 +  | take 1 (CONS (x,_)) = CONS (x, K NIL)
  5.4449 +  | take n (CONS (x,xs)) = CONS (x, fn () => take (n - 1) (xs ()));
  5.4450 +
  5.4451 +fun drop n s = funpow n tl s handle Empty => raise Subscript;
  5.4452 +
  5.4453 +(* ------------------------------------------------------------------------- *)
  5.4454 +(* Stream versions of standard list operations: these might not terminate    *)
  5.4455 +(* ------------------------------------------------------------------------- *)
  5.4456 +
  5.4457 +local
  5.4458 +  fun len n NIL = n
  5.4459 +    | len n (CONS (_,t)) = len (n + 1) (t ());
  5.4460 +in
  5.4461 +  fun length s = len 0 s;
  5.4462 +end;
  5.4463 +
  5.4464 +fun exists pred =
  5.4465 +    let
  5.4466 +      fun f NIL = false
  5.4467 +        | f (CONS (h,t)) = pred h orelse f (t ())
  5.4468 +    in
  5.4469 +      f
  5.4470 +    end;
  5.4471 +
  5.4472 +fun all pred = not o exists (not o pred);
  5.4473 +
  5.4474 +fun filter p NIL = NIL
  5.4475 +  | filter p (CONS (x,xs)) =
  5.4476 +    if p x then CONS (x, fn () => filter p (xs ())) else filter p (xs ());
  5.4477 +
  5.4478 +fun foldl f =
  5.4479 +    let
  5.4480 +      fun fold b NIL = b
  5.4481 +        | fold b (CONS (h,t)) = fold (f (h,b)) (t ())
  5.4482 +    in
  5.4483 +      fold
  5.4484 +    end;
  5.4485 +
  5.4486 +fun concat NIL = NIL
  5.4487 +  | concat (CONS (NIL, ss)) = concat (ss ())
  5.4488 +  | concat (CONS (CONS (x, xs), ss)) =
  5.4489 +    CONS (x, fn () => concat (CONS (xs (), ss)));
  5.4490 +
  5.4491 +fun mapPartial f =
  5.4492 +    let
  5.4493 +      fun mp NIL = NIL
  5.4494 +        | mp (CONS (h,t)) =
  5.4495 +          case f h of
  5.4496 +            NONE => mp (t ())
  5.4497 +          | SOME h' => CONS (h', fn () => mp (t ()))
  5.4498 +    in
  5.4499 +      mp
  5.4500 +    end;
  5.4501 +
  5.4502 +fun mapsPartial f =
  5.4503 +    let
  5.4504 +      fun mm _ NIL = NIL
  5.4505 +        | mm s (CONS (x, xs)) =
  5.4506 +          let
  5.4507 +            val (yo, s') = f x s
  5.4508 +            val t = mm s' o xs
  5.4509 +          in
  5.4510 +            case yo of NONE => t () | SOME y => CONS (y, t)
  5.4511 +          end
  5.4512 +    in
  5.4513 +      mm
  5.4514 +    end;
  5.4515 +
  5.4516 +(* ------------------------------------------------------------------------- *)
  5.4517 +(* Stream operations                                                         *)
  5.4518 +(* ------------------------------------------------------------------------- *)
  5.4519 +
  5.4520 +fun memoize NIL = NIL
  5.4521 +  | memoize (CONS (h,t)) = CONS (h, Lazy.memoize (fn () => memoize (t ())));
  5.4522 +
  5.4523 +local
  5.4524 +  fun toLst res NIL = rev res
  5.4525 +    | toLst res (CONS (x, xs)) = toLst (x :: res) (xs ());
  5.4526 +in
  5.4527 +  fun toList s = toLst [] s;
  5.4528 +end;
  5.4529 +
  5.4530 +fun fromList [] = NIL
  5.4531 +  | fromList (x :: xs) = CONS (x, fn () => fromList xs);
  5.4532 +
  5.4533 +fun toTextFile {filename = f} s =
  5.4534 +    let
  5.4535 +      val (h,close) =
  5.4536 +          if f = "-" then (TextIO.stdOut, K ())
  5.4537 +          else (TextIO.openOut f, TextIO.closeOut)
  5.4538 +
  5.4539 +      fun toFile NIL = ()
  5.4540 +        | toFile (CONS (x,y)) = (TextIO.output (h,x); toFile (y ()))
  5.4541 +
  5.4542 +      val () = toFile s
  5.4543 +    in
  5.4544 +      close h
  5.4545 +    end;
  5.4546 +
  5.4547 +fun fromTextFile {filename = f} =
  5.4548 +    let
  5.4549 +      val (h,close) =
  5.4550 +          if f = "-" then (TextIO.stdIn, K ())
  5.4551 +          else (TextIO.openIn f, TextIO.closeIn)
  5.4552 +
  5.4553 +      fun strm () =
  5.4554 +          case TextIO.inputLine h of
  5.4555 +            NONE => (close h; NIL)
  5.4556 +          | SOME s => CONS (s,strm)
  5.4557 +    in
  5.4558 +      memoize (strm ())
  5.4559 +    end;
  5.4560 +
  5.4561 +end
  5.4562 +end;
  5.4563 +
  5.4564 +(**** Original file: Heap.sig ****)
  5.4565 +
  5.4566 +(* ========================================================================= *)
  5.4567 +(* A HEAP DATATYPE FOR ML                                                    *)
  5.4568 +(* Copyright (c) 2001-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.4569 +(* ========================================================================= *)
  5.4570 +
  5.4571 +signature Heap =
  5.4572 +sig
  5.4573 +
  5.4574 +type 'a heap
  5.4575 +
  5.4576 +val new : ('a * 'a -> order) -> 'a heap
  5.4577 +
  5.4578 +val add : 'a heap -> 'a -> 'a heap
  5.4579 +
  5.4580 +val null : 'a heap -> bool
  5.4581 +
  5.4582 +val top : 'a heap -> 'a  (* raises Empty *)
  5.4583 +
  5.4584 +val remove : 'a heap -> 'a * 'a heap  (* raises Empty *)
  5.4585 +
  5.4586 +val size : 'a heap -> int
  5.4587 +
  5.4588 +val app : ('a -> unit) -> 'a heap -> unit
  5.4589 +
  5.4590 +val toList : 'a heap -> 'a list
  5.4591 +
  5.4592 +val toStream : 'a heap -> 'a Metis.Stream.stream
  5.4593 +
  5.4594 +val toString : 'a heap -> string
  5.4595 +
  5.4596 +end
  5.4597 +
  5.4598 +(**** Original file: Heap.sml ****)
  5.4599 +
  5.4600 +structure Metis = struct open Metis
  5.4601 +(* Metis-specific ML environment *)
  5.4602 +nonfix ++ -- RL mem union subset;
  5.4603 +val explode = String.explode;
  5.4604 +val implode = String.implode;
  5.4605 +val print = TextIO.print;
  5.4606 +(* ========================================================================= *)
  5.4607 +(* A HEAP DATATYPE FOR ML                                                    *)
  5.4608 +(* Copyright (c) 2001-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.4609 +(* ========================================================================= *)
  5.4610 +
  5.4611 +structure Heap :> Heap =
  5.4612 +struct
  5.4613 +
  5.4614 +(* Leftist heaps as in Purely Functional Data Structures, by Chris Okasaki *)
  5.4615 +
  5.4616 +datatype 'a node = E | T of int * 'a * 'a node * 'a node;
  5.4617 +
  5.4618 +datatype 'a heap = Heap of ('a * 'a -> order) * int * 'a node;
  5.4619 +
  5.4620 +fun rank E = 0
  5.4621 +  | rank (T (r,_,_,_)) = r;
  5.4622 +
  5.4623 +fun makeT (x,a,b) =
  5.4624 +  if rank a >= rank b then T (rank b + 1, x, a, b) else T (rank a + 1, x, b, a);
  5.4625 +
  5.4626 +fun merge cmp =
  5.4627 +    let
  5.4628 +      fun mrg (h,E) = h
  5.4629 +        | mrg (E,h) = h
  5.4630 +        | mrg (h1 as T (_,x,a1,b1), h2 as T (_,y,a2,b2)) =
  5.4631 +          case cmp (x,y) of
  5.4632 +            GREATER => makeT (y, a2, mrg (h1,b2))
  5.4633 +          | _ => makeT (x, a1, mrg (b1,h2))
  5.4634 +    in
  5.4635 +      mrg
  5.4636 +    end;
  5.4637 +
  5.4638 +fun new cmp = Heap (cmp,0,E);
  5.4639 +
  5.4640 +fun add (Heap (f,n,a)) x = Heap (f, n + 1, merge f (T (1,x,E,E), a));
  5.4641 +
  5.4642 +fun size (Heap (_, n, _)) = n;
  5.4643 +
  5.4644 +fun null h = size h = 0;
  5.4645 +
  5.4646 +fun top (Heap (_,_,E)) = raise Empty
  5.4647 +  | top (Heap (_, _, T (_,x,_,_))) = x;
  5.4648 +
  5.4649 +fun remove (Heap (_,_,E)) = raise Empty
  5.4650 +  | remove (Heap (f, n, T (_,x,a,b))) = (x, Heap (f, n - 1, merge f (a,b)));
  5.4651 +
  5.4652 +fun app f =
  5.4653 +    let
  5.4654 +      fun ap [] = ()
  5.4655 +        | ap (E :: rest) = ap rest
  5.4656 +        | ap (T (_,d,a,b) :: rest) = (f d; ap (a :: b :: rest))
  5.4657 +    in
  5.4658 +      fn Heap (_,_,a) => ap [a]
  5.4659 +    end;
  5.4660 +
  5.4661 +fun toList h =
  5.4662 +    if null h then []
  5.4663 +    else
  5.4664 +      let
  5.4665 +        val (x,h) = remove h
  5.4666 +      in
  5.4667 +        x :: toList h
  5.4668 +      end;
  5.4669 +
  5.4670 +fun toStream h =
  5.4671 +    if null h then Stream.NIL
  5.4672 +    else
  5.4673 +      let
  5.4674 +        val (x,h) = remove h
  5.4675 +      in
  5.4676 +        Stream.CONS (x, fn () => toStream h)
  5.4677 +      end;
  5.4678 +
  5.4679 +fun toString h =
  5.4680 +    "Heap[" ^ (if null h then "" else Int.toString (size h)) ^ "]";
  5.4681 +
  5.4682 +end
  5.4683 +end;
  5.4684 +
  5.4685 +(**** Original file: Parser.sig ****)
  5.4686 +
  5.4687 +(* ========================================================================= *)
  5.4688 +(* PARSING AND PRETTY PRINTING                                               *)
  5.4689 +(* Copyright (c) 2001-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.4690 +(* ========================================================================= *)
  5.4691 +
  5.4692 +signature Parser =
  5.4693 +sig
  5.4694 +
  5.4695 +(* ------------------------------------------------------------------------- *)
  5.4696 +(* Pretty printing for built-in types                                        *)
  5.4697 +(* ------------------------------------------------------------------------- *)
  5.4698 +
  5.4699 +type ppstream = Metis.PP.ppstream
  5.4700 +
  5.4701 +datatype breakStyle = Consistent | Inconsistent
  5.4702 +
  5.4703 +type 'a pp = ppstream -> 'a -> unit
  5.4704 +
  5.4705 +val lineLength : int ref
  5.4706 +
  5.4707 +val beginBlock : ppstream -> breakStyle -> int -> unit
  5.4708 +
  5.4709 +val endBlock : ppstream -> unit
  5.4710 +
  5.4711 +val addString : ppstream -> string -> unit
  5.4712 +
  5.4713 +val addBreak : ppstream -> int * int -> unit
  5.4714 +
  5.4715 +val addNewline : ppstream -> unit
  5.4716 +
  5.4717 +val ppMap : ('a -> 'b) -> 'b pp -> 'a pp
  5.4718 +
  5.4719 +val ppBracket : string -> string -> 'a pp -> 'a pp
  5.4720 +
  5.4721 +val ppSequence : string -> 'a pp -> 'a list pp
  5.4722 +
  5.4723 +val ppBinop : string -> 'a pp -> 'b pp -> ('a * 'b) pp
  5.4724 +
  5.4725 +val ppChar : char pp
  5.4726 +
  5.4727 +val ppString : string pp
  5.4728 +
  5.4729 +val ppUnit : unit pp
  5.4730 +
  5.4731 +val ppBool : bool pp
  5.4732 +
  5.4733 +val ppInt : int pp
  5.4734 +
  5.4735 +val ppReal : real pp
  5.4736 +
  5.4737 +val ppOrder : order pp
  5.4738 +
  5.4739 +val ppList : 'a pp -> 'a list pp
  5.4740 +
  5.4741 +val ppOption : 'a pp -> 'a option pp
  5.4742 +
  5.4743 +val ppPair : 'a pp -> 'b pp -> ('a * 'b) pp
  5.4744 +
  5.4745 +val ppTriple : 'a pp -> 'b pp -> 'c pp -> ('a * 'b * 'c) pp
  5.4746 +
  5.4747 +val toString : 'a pp -> 'a -> string  (* Uses !lineLength *)
  5.4748 +
  5.4749 +val fromString : ('a -> string) -> 'a pp
  5.4750 +
  5.4751 +val ppTrace : 'a pp -> string -> 'a -> unit
  5.4752 +
  5.4753 +(* ------------------------------------------------------------------------- *)
  5.4754 +(* Recursive descent parsing combinators                                     *)
  5.4755 +(* ------------------------------------------------------------------------- *)
  5.4756 +
  5.4757 +(* Generic parsers
  5.4758 +
  5.4759 +Recommended fixities:
  5.4760 +  infixr 9 >>++
  5.4761 +  infixr 8 ++
  5.4762 +  infixr 7 >>
  5.4763 +  infixr 6 ||
  5.4764 +*)
  5.4765 +
  5.4766 +exception NoParse
  5.4767 +
  5.4768 +val error : 'a -> 'b * 'a
  5.4769 +
  5.4770 +val ++ : ('a -> 'b * 'a) * ('a -> 'c * 'a) -> 'a -> ('b * 'c) * 'a
  5.4771 +
  5.4772 +val >> : ('a -> 'b * 'a) * ('b -> 'c) -> 'a -> 'c * 'a
  5.4773 +
  5.4774 +val >>++ : ('a -> 'b * 'a) * ('b -> 'a -> 'c * 'a) -> 'a -> 'c * 'a
  5.4775 +
  5.4776 +val || : ('a -> 'b * 'a) * ('a -> 'b * 'a) -> 'a -> 'b * 'a
  5.4777 +
  5.4778 +val first : ('a -> 'b * 'a) list -> 'a -> 'b * 'a
  5.4779 +
  5.4780 +val mmany : ('s -> 'a -> 's * 'a) -> 's -> 'a -> 's * 'a
  5.4781 +
  5.4782 +val many : ('a -> 'b * 'a) -> 'a -> 'b list * 'a
  5.4783 +
  5.4784 +val atLeastOne : ('a -> 'b * 'a) -> 'a -> 'b list * 'a
  5.4785 +
  5.4786 +val nothing : 'a -> unit * 'a
  5.4787 +
  5.4788 +val optional : ('a -> 'b * 'a) -> 'a -> 'b option * 'a
  5.4789 +
  5.4790 +(* Stream based parsers *)
  5.4791 +
  5.4792 +type ('a,'b) parser = 'a Metis.Stream.stream -> 'b * 'a Metis.Stream.stream
  5.4793 +
  5.4794 +val everything : ('a, 'b list) parser -> 'a Metis.Stream.stream -> 'b Metis.Stream.stream
  5.4795 +
  5.4796 +val maybe : ('a -> 'b option) -> ('a,'b) parser
  5.4797 +
  5.4798 +val finished : ('a,unit) parser
  5.4799 +
  5.4800 +val some : ('a -> bool) -> ('a,'a) parser
  5.4801 +
  5.4802 +val any : ('a,'a) parser
  5.4803 +
  5.4804 +val exact : ''a -> (''a,''a) parser
  5.4805 +
  5.4806 +(* ------------------------------------------------------------------------- *)
  5.4807 +(* Infix operators                                                           *)
  5.4808 +(* ------------------------------------------------------------------------- *)
  5.4809 +
  5.4810 +type infixities = {token : string, precedence : int, leftAssoc : bool} list
  5.4811 +
  5.4812 +val infixTokens : infixities -> string list
  5.4813 +
  5.4814 +val parseInfixes :
  5.4815 +    infixities -> (string * 'a * 'a -> 'a) -> (string,'a) parser ->
  5.4816 +    (string,'a) parser
  5.4817 +
  5.4818 +val ppInfixes :
  5.4819 +    infixities -> ('a -> (string * 'a * 'a) option) -> ('a * bool) pp ->
  5.4820 +    ('a * bool) pp
  5.4821 +
  5.4822 +(* ------------------------------------------------------------------------- *)
  5.4823 +(* Quotations                                                                *)
  5.4824 +(* ------------------------------------------------------------------------- *)
  5.4825 +
  5.4826 +type 'a quotation = 'a Metis.frag list
  5.4827 +
  5.4828 +val parseQuotation : ('a -> string) -> (string -> 'b) -> 'a quotation -> 'b
  5.4829 +
  5.4830 +end
  5.4831 +
  5.4832 +(**** Original file: Parser.sml ****)
  5.4833 +
  5.4834 +structure Metis = struct open Metis
  5.4835 +(* Metis-specific ML environment *)
  5.4836 +nonfix ++ -- RL mem union subset;
  5.4837 +val explode = String.explode;
  5.4838 +val implode = String.implode;
  5.4839 +val print = TextIO.print;
  5.4840 +(* ========================================================================= *)
  5.4841 +(* PARSER COMBINATORS                                                        *)
  5.4842 +(* Copyright (c) 2001-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.4843 +(* ========================================================================= *)
  5.4844 +
  5.4845 +structure Parser :> Parser =
  5.4846 +struct
  5.4847 +
  5.4848 +infixr 9 >>++
  5.4849 +infixr 8 ++
  5.4850 +infixr 7 >>
  5.4851 +infixr 6 ||
  5.4852 +
  5.4853 +(* ------------------------------------------------------------------------- *)
  5.4854 +(* Helper functions.                                                         *)
  5.4855 +(* ------------------------------------------------------------------------- *)
  5.4856 +
  5.4857 +exception Bug = Useful.Bug;
  5.4858 +
  5.4859 +val trace = Useful.trace
  5.4860 +and equal = Useful.equal
  5.4861 +and I = Useful.I
  5.4862 +and K = Useful.K
  5.4863 +and C = Useful.C
  5.4864 +and fst = Useful.fst
  5.4865 +and snd = Useful.snd
  5.4866 +and pair = Useful.pair
  5.4867 +and curry = Useful.curry
  5.4868 +and funpow = Useful.funpow
  5.4869 +and mem = Useful.mem
  5.4870 +and sortMap = Useful.sortMap;
  5.4871 +
  5.4872 +(* ------------------------------------------------------------------------- *)
  5.4873 +(* Pretty printing for built-in types                                        *)
  5.4874 +(* ------------------------------------------------------------------------- *)
  5.4875 +
  5.4876 +type ppstream = PP.ppstream
  5.4877 +
  5.4878 +datatype breakStyle = Consistent | Inconsistent
  5.4879 +
  5.4880 +type 'a pp = PP.ppstream -> 'a -> unit;
  5.4881 +
  5.4882 +val lineLength = ref 75;
  5.4883 +
  5.4884 +fun beginBlock pp Consistent = PP.begin_block pp PP.CONSISTENT
  5.4885 +  | beginBlock pp Inconsistent = PP.begin_block pp PP.INCONSISTENT;
  5.4886 +
  5.4887 +val endBlock = PP.end_block
  5.4888 +and addString = PP.add_string
  5.4889 +and addBreak = PP.add_break
  5.4890 +and addNewline = PP.add_newline;
  5.4891 +
  5.4892 +fun ppMap f ppA (ppstrm : PP.ppstream) x : unit = ppA ppstrm (f x);
  5.4893 +
  5.4894 +fun ppBracket l r ppA pp a =
  5.4895 +    let
  5.4896 +      val ln = size l
  5.4897 +    in
  5.4898 +      beginBlock pp Inconsistent ln;
  5.4899 +      if ln = 0 then () else addString pp l;
  5.4900 +      ppA pp a;
  5.4901 +      if r = "" then () else addString pp r;
  5.4902 +      endBlock pp
  5.4903 +    end;
  5.4904 +
  5.4905 +fun ppSequence sep ppA pp =
  5.4906 +    let
  5.4907 +      fun ppX x = (addString pp sep; addBreak pp (1,0); ppA pp x)
  5.4908 +    in
  5.4909 +      fn [] => ()
  5.4910 +       | h :: t =>
  5.4911 +         (beginBlock pp Inconsistent 0;
  5.4912 +          ppA pp h;
  5.4913 +          app ppX t;
  5.4914 +          endBlock pp)
  5.4915 +    end;
  5.4916 +
  5.4917 +fun ppBinop s ppA ppB pp (a,b) =
  5.4918 +    (beginBlock pp Inconsistent 0;
  5.4919 +      ppA pp a;
  5.4920 +      if s = "" then () else addString pp s;
  5.4921 +      addBreak pp (1,0);
  5.4922 +      ppB pp b;
  5.4923 +      endBlock pp);
  5.4924 +
  5.4925 +fun ppTrinop ab bc ppA ppB ppC pp (a,b,c) =
  5.4926 +    (beginBlock pp Inconsistent 0;
  5.4927 +     ppA pp a;
  5.4928 +     if ab = "" then () else addString pp ab;
  5.4929 +     addBreak pp (1,0);
  5.4930 +     ppB pp b;
  5.4931 +     if bc = "" then () else addString pp bc;
  5.4932 +     addBreak pp (1,0);
  5.4933 +     ppC pp c;
  5.4934 +     endBlock pp);
  5.4935 +
  5.4936 +(* Pretty-printers for common types *)
  5.4937 +
  5.4938 +fun ppString pp s =
  5.4939 +    (beginBlock pp Inconsistent 0;
  5.4940 +     addString pp s;
  5.4941 +     endBlock pp);
  5.4942 +
  5.4943 +val ppUnit = ppMap (fn () => "()") ppString;
  5.4944 +
  5.4945 +val ppChar = ppMap str ppString;
  5.4946 +
  5.4947 +val ppBool = ppMap (fn true => "true" | false => "false") ppString;
  5.4948 +
  5.4949 +val ppInt = ppMap Int.toString ppString;
  5.4950 +
  5.4951 +val ppReal = ppMap Real.toString ppString;
  5.4952 +
  5.4953 +val ppOrder =
  5.4954 +    let
  5.4955 +      fun f LESS = "Less"
  5.4956 +        | f EQUAL = "Equal"
  5.4957 +        | f GREATER = "Greater"
  5.4958 +    in
  5.4959 +      ppMap f ppString
  5.4960 +    end;
  5.4961 +
  5.4962 +fun ppList ppA = ppBracket "[" "]" (ppSequence "," ppA);
  5.4963 +
  5.4964 +fun ppOption _ pp NONE = ppString pp "-"
  5.4965 +  | ppOption ppA pp (SOME a) = ppA pp a;
  5.4966 +
  5.4967 +fun ppPair ppA ppB = ppBracket "(" ")" (ppBinop "," ppA ppB);
  5.4968 +
  5.4969 +fun ppTriple ppA ppB ppC = ppBracket "(" ")" (ppTrinop "," "," ppA ppB ppC);
  5.4970 +
  5.4971 +fun toString ppA a = PP.pp_to_string (!lineLength) ppA a;
  5.4972 +
  5.4973 +fun fromString toS = ppMap toS ppString;
  5.4974 +
  5.4975 +fun ppTrace ppX nameX x =
  5.4976 +    trace (toString (ppBinop " =" ppString ppX) (nameX,x) ^ "\n");
  5.4977 +
  5.4978 +(* ------------------------------------------------------------------------- *)
  5.4979 +(* Generic.                                                                  *)
  5.4980 +(* ------------------------------------------------------------------------- *)
  5.4981 +
  5.4982 +exception NoParse;
  5.4983 +
  5.4984 +val error : 'a -> 'b * 'a = fn _ => raise NoParse;
  5.4985 +
  5.4986 +fun op ++ (parser1,parser2) input =
  5.4987 +    let
  5.4988 +      val (result1,input) = parser1 input
  5.4989 +      val (result2,input) = parser2 input
  5.4990 +    in
  5.4991 +      ((result1,result2),input)
  5.4992 +    end;
  5.4993 +
  5.4994 +fun op >> (parser : 'a -> 'b * 'a, treatment) input =
  5.4995 +    let
  5.4996 +      val (result,input) = parser input
  5.4997 +    in
  5.4998 +      (treatment result, input)
  5.4999 +    end;
  5.5000 +
  5.5001 +fun op >>++ (parser,treatment) input =
  5.5002 +    let
  5.5003 +      val (result,input) = parser input
  5.5004 +    in
  5.5005 +      treatment result input
  5.5006 +    end;
  5.5007 +
  5.5008 +fun op || (parser1,parser2) input =
  5.5009 +    parser1 input handle NoParse => parser2 input;
  5.5010 +
  5.5011 +fun first [] _ = raise NoParse
  5.5012 +  | first (parser :: parsers) input = (parser || first parsers) input;
  5.5013 +
  5.5014 +fun mmany parser state input =
  5.5015 +    let
  5.5016 +      val (state,input) = parser state input
  5.5017 +    in
  5.5018 +      mmany parser state input
  5.5019 +    end
  5.5020 +    handle NoParse => (state,input);
  5.5021 +
  5.5022 +fun many parser =
  5.5023 +    let
  5.5024 +      fun sparser l = parser >> (fn x => x :: l)
  5.5025 +    in
  5.5026 +      mmany sparser [] >> rev      
  5.5027 +    end;
  5.5028 +
  5.5029 +fun atLeastOne p = (p ++ many p) >> op::;
  5.5030 +
  5.5031 +fun nothing input = ((),input);
  5.5032 +
  5.5033 +fun optional p = (p >> SOME) || (nothing >> K NONE);
  5.5034 +
  5.5035 +(* ------------------------------------------------------------------------- *)
  5.5036 +(* Stream-based.                                                             *)
  5.5037 +(* ------------------------------------------------------------------------- *)
  5.5038 +
  5.5039 +type ('a,'b) parser = 'a Stream.stream -> 'b * 'a Stream.stream
  5.5040 +
  5.5041 +fun everything parser =
  5.5042 +    let
  5.5043 +      fun f input =
  5.5044 +          let
  5.5045 +            val (result,input) = parser input
  5.5046 +          in
  5.5047 +            Stream.append (Stream.fromList result) (fn () => f input)
  5.5048 +          end
  5.5049 +          handle NoParse =>
  5.5050 +            if Stream.null input then Stream.NIL else raise NoParse
  5.5051 +    in
  5.5052 +      f
  5.5053 +    end;
  5.5054 +
  5.5055 +fun maybe p Stream.NIL = raise NoParse
  5.5056 +  | maybe p (Stream.CONS (h,t)) =
  5.5057 +    case p h of SOME r => (r, t ()) | NONE => raise NoParse;
  5.5058 +
  5.5059 +fun finished Stream.NIL = ((), Stream.NIL)
  5.5060 +  | finished (Stream.CONS _) = raise NoParse;
  5.5061 +
  5.5062 +fun some p = maybe (fn x => if p x then SOME x else NONE);
  5.5063 +
  5.5064 +fun any input = some (K true) input;
  5.5065 +
  5.5066 +fun exact tok = some (fn item => item = tok);
  5.5067 +
  5.5068 +(* ------------------------------------------------------------------------- *)
  5.5069 +(* Parsing and pretty-printing for infix operators.                          *)
  5.5070 +(* ------------------------------------------------------------------------- *)
  5.5071 +
  5.5072 +type infixities = {token : string, precedence : int, leftAssoc : bool} list;
  5.5073 +
  5.5074 +local
  5.5075 +  fun unflatten ({token,precedence,leftAssoc}, ([],_)) =
  5.5076 +      ([(leftAssoc, [token])], precedence)
  5.5077 +    | unflatten ({token,precedence,leftAssoc}, ((a,l) :: dealt, p)) =
  5.5078 +      if p = precedence then
  5.5079 +        let
  5.5080 +          val _ = leftAssoc = a orelse
  5.5081 +                  raise Bug "infix parser/printer: mixed assocs"
  5.5082 +        in
  5.5083 +          ((a, token :: l) :: dealt, p)
  5.5084 +        end
  5.5085 +      else
  5.5086 +        ((leftAssoc,[token]) :: (a,l) :: dealt, precedence);
  5.5087 +in
  5.5088 +  fun layerOps infixes =
  5.5089 +      let
  5.5090 +        val infixes = sortMap #precedence Int.compare infixes
  5.5091 +        val (parsers,_) = foldl unflatten ([],0) infixes
  5.5092 +      in
  5.5093 +        parsers
  5.5094 +      end;
  5.5095 +end;
  5.5096 +
  5.5097 +local
  5.5098 +  fun chop (#" " :: chs) = let val (n,l) = chop chs in (n + 1, l) end
  5.5099 +    | chop chs = (0,chs);
  5.5100 +
  5.5101 +  fun nspaces n = funpow n (curry op^ " ") "";
  5.5102 +
  5.5103 +  fun spacify tok =
  5.5104 +      let
  5.5105 +        val chs = explode tok
  5.5106 +        val (r,chs) = chop (rev chs)
  5.5107 +        val (l,chs) = chop (rev chs)
  5.5108 +      in
  5.5109 +        ((l,r), implode chs)
  5.5110 +      end;
  5.5111 +
  5.5112 +  fun lrspaces (l,r) =
  5.5113 +      (if l = 0 then K () else C addString (nspaces l),
  5.5114 +       if r = 0 then K () else C addBreak (r, 0));
  5.5115 +in
  5.5116 +  fun opSpaces s = let val (l_r,s) = spacify s in (lrspaces l_r, s) end;
  5.5117 +
  5.5118 +  val opClean = snd o spacify;
  5.5119 +end;
  5.5120 +
  5.5121 +val infixTokens : infixities -> string list =
  5.5122 +    List.map (fn {token,...} => opClean token);
  5.5123 +
  5.5124 +fun parseGenInfix update sof toks parse inp =
  5.5125 +    let
  5.5126 +      val (e, rest) = parse inp
  5.5127 +                      
  5.5128 +      val continue =
  5.5129 +          case rest of
  5.5130 +            Stream.NIL => NONE
  5.5131 +          | Stream.CONS (h, t) => if mem h toks then SOME (h, t) else NONE
  5.5132 +    in
  5.5133 +      case continue of
  5.5134 +        NONE => (sof e, rest)
  5.5135 +      | SOME (h,t) => parseGenInfix update (update sof h e) toks parse (t ())
  5.5136 +    end;
  5.5137 +
  5.5138 +fun parseLeftInfix toks con =
  5.5139 +    parseGenInfix (fn f => fn t => fn a => fn b => con (t, f a, b)) I toks;
  5.5140 +
  5.5141 +fun parseRightInfix toks con =
  5.5142 +    parseGenInfix (fn f => fn t => fn a => fn b => f (con (t, a, b))) I toks;
  5.5143 +
  5.5144 +fun parseInfixes ops =
  5.5145 +    let
  5.5146 +      fun layeredOp (x,y) = (x, List.map opClean y)
  5.5147 +
  5.5148 +      val layeredOps = List.map layeredOp (layerOps ops)
  5.5149 +
  5.5150 +      fun iparser (a,t) = (if a then parseLeftInfix else parseRightInfix) t
  5.5151 +
  5.5152 +      val iparsers = List.map iparser layeredOps
  5.5153 +    in
  5.5154 +      fn con => fn subparser => foldl (fn (p,sp) => p con sp) subparser iparsers
  5.5155 +    end;
  5.5156 +
  5.5157 +fun ppGenInfix left toks =
  5.5158 +    let
  5.5159 +      val spc = List.map opSpaces toks
  5.5160 +    in
  5.5161 +      fn dest => fn ppSub =>
  5.5162 +      let
  5.5163 +        fun dest' tm =
  5.5164 +            case dest tm of
  5.5165 +              NONE => NONE
  5.5166 +            | SOME (t, a, b) =>
  5.5167 +              Option.map (pair (a,b)) (List.find (equal t o snd) spc)
  5.5168 +
  5.5169 +        open PP
  5.5170 +
  5.5171 +        fun ppGo pp (tmr as (tm,r)) =
  5.5172 +            case dest' tm of
  5.5173 +              NONE => ppSub pp tmr
  5.5174 +            | SOME ((a,b),((lspc,rspc),tok)) =>
  5.5175 +              ((if left then ppGo else ppSub) pp (a,true);
  5.5176 +               lspc pp; addString pp tok; rspc pp;
  5.5177 +               (if left then ppSub else ppGo) pp (b,r))
  5.5178 +      in
  5.5179 +        fn pp => fn tmr as (tm,_) =>
  5.5180 +        case dest' tm of
  5.5181 +          NONE => ppSub pp tmr
  5.5182 +        | SOME _ => (beginBlock pp Inconsistent 0; ppGo pp tmr; endBlock pp)
  5.5183 +      end
  5.5184 +    end;
  5.5185 +
  5.5186 +fun ppLeftInfix toks = ppGenInfix true toks;
  5.5187 +
  5.5188 +fun ppRightInfix toks = ppGenInfix false toks;
  5.5189 +
  5.5190 +fun ppInfixes ops =
  5.5191 +    let
  5.5192 +      val layeredOps = layerOps ops
  5.5193 +                       
  5.5194 +      val toks = List.concat (List.map (List.map opClean o snd) layeredOps)
  5.5195 +                 
  5.5196 +      fun iprinter (a,t) = (if a then ppLeftInfix else ppRightInfix) t
  5.5197 +                           
  5.5198 +      val iprinters = List.map iprinter layeredOps
  5.5199 +    in
  5.5200 +      fn dest => fn ppSub =>
  5.5201 +      let
  5.5202 +        fun printer sub = foldl (fn (ip,p) => ip dest p) sub iprinters
  5.5203 +
  5.5204 +        fun isOp t = case dest t of SOME (x,_,_) => mem x toks | _ => false
  5.5205 +
  5.5206 +        open PP
  5.5207 +
  5.5208 +        fun subpr pp (tmr as (tm,_)) =
  5.5209 +            if isOp tm then
  5.5210 +              (beginBlock pp Inconsistent 1; addString pp "(";
  5.5211 +               printer subpr pp (tm, false); addString pp ")"; endBlock pp)
  5.5212 +            else ppSub pp tmr
  5.5213 +      in
  5.5214 +        fn pp => fn tmr =>
  5.5215 +        (beginBlock pp Inconsistent 0; printer subpr pp tmr; endBlock pp)
  5.5216 +      end
  5.5217 +    end;
  5.5218 +
  5.5219 +(* ------------------------------------------------------------------------- *)
  5.5220 +(* Quotations                                                                *)
  5.5221 +(* ------------------------------------------------------------------------- *)
  5.5222 +
  5.5223 +type 'a quotation = 'a frag list;
  5.5224 +
  5.5225 +fun parseQuotation printer parser quote =
  5.5226 +  let
  5.5227 +    fun expand (QUOTE q, s) = s ^ q
  5.5228 +      | expand (ANTIQUOTE a, s) = s ^ printer a
  5.5229 +
  5.5230 +    val string = foldl expand "" quote
  5.5231 +  in
  5.5232 +    parser string
  5.5233 +  end;
  5.5234 +
  5.5235 +end
  5.5236 +end;
  5.5237 +
  5.5238 +(**** Original file: Options.sig ****)
  5.5239 +
  5.5240 +(* ========================================================================= *)
  5.5241 +(* PROCESSING COMMAND LINE OPTIONS                                           *)
  5.5242 +(* Copyright (c) 2003-2004 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.5243 +(* ========================================================================= *)
  5.5244 +
  5.5245 +signature Options =
  5.5246 +sig
  5.5247 +
  5.5248 +(* ------------------------------------------------------------------------- *)
  5.5249 +(* Option processors take an option with its associated arguments.           *)
  5.5250 +(* ------------------------------------------------------------------------- *)
  5.5251 +
  5.5252 +type proc = string * string list -> unit
  5.5253 +
  5.5254 +type ('a,'x) mkProc = ('x -> proc) -> ('a -> 'x) -> proc
  5.5255 +
  5.5256 +(* ------------------------------------------------------------------------- *)
  5.5257 +(* One command line option: names, arguments, description and a processor.   *)
  5.5258 +(* ------------------------------------------------------------------------- *)
  5.5259 +
  5.5260 +type opt =
  5.5261 +     {switches : string list, arguments : string list,
  5.5262 +      description : string, processor : proc}
  5.5263 +
  5.5264 +(* ------------------------------------------------------------------------- *)
  5.5265 +(* Option processors may raise an OptionExit exception.                      *)
  5.5266 +(* ------------------------------------------------------------------------- *)
  5.5267 +
  5.5268 +type optionExit = {message : string option, usage : bool, success : bool}
  5.5269 +
  5.5270 +exception OptionExit of optionExit
  5.5271 +
  5.5272 +(* ------------------------------------------------------------------------- *)
  5.5273 +(* Constructing option processors.                                           *)
  5.5274 +(* ------------------------------------------------------------------------- *)
  5.5275 +
  5.5276 +val beginOpt : (string,'x) mkProc
  5.5277 +
  5.5278 +val endOpt : unit -> proc
  5.5279 +
  5.5280 +val stringOpt : (string,'x) mkProc
  5.5281 +
  5.5282 +val intOpt : int option * int option -> (int,'x) mkProc
  5.5283 +
  5.5284 +val realOpt : real option * real option -> (real,'x) mkProc
  5.5285 +
  5.5286 +val enumOpt : string list -> (string,'x) mkProc
  5.5287 +
  5.5288 +val optionOpt : string * ('a,'x) mkProc -> ('a option,'x) mkProc
  5.5289 +
  5.5290 +(* ------------------------------------------------------------------------- *)
  5.5291 +(* Basic options useful for all programs.                                    *)
  5.5292 +(* ------------------------------------------------------------------------- *)
  5.5293 +
  5.5294 +val basicOptions : opt list
  5.5295 +
  5.5296 +(* ------------------------------------------------------------------------- *)
  5.5297 +(* All the command line options of a program.                                *)
  5.5298 +(* ------------------------------------------------------------------------- *)
  5.5299 +
  5.5300 +type allOptions =
  5.5301 +     {name : string, version : string, header : string,
  5.5302 +      footer : string, options : opt list}
  5.5303 +
  5.5304 +(* ------------------------------------------------------------------------- *)
  5.5305 +(* Usage information.                                                        *)
  5.5306 +(* ------------------------------------------------------------------------- *)
  5.5307 +
  5.5308 +val versionInformation : allOptions -> string
  5.5309 +
  5.5310 +val usageInformation : allOptions -> string
  5.5311 +
  5.5312 +(* ------------------------------------------------------------------------- *)
  5.5313 +(* Exit the program gracefully.                                              *)
  5.5314 +(* ------------------------------------------------------------------------- *)
  5.5315 +
  5.5316 +val exit : allOptions -> optionExit -> 'exit
  5.5317 +
  5.5318 +val succeed : allOptions -> 'exit
  5.5319 +
  5.5320 +val fail : allOptions -> string -> 'exit
  5.5321 +
  5.5322 +val usage : allOptions -> string -> 'exit
  5.5323 +
  5.5324 +val version : allOptions -> 'exit
  5.5325 +
  5.5326 +(* ------------------------------------------------------------------------- *)
  5.5327 +(* Process the command line options passed to the program.                   *)
  5.5328 +(* ------------------------------------------------------------------------- *)
  5.5329 +
  5.5330 +val processOptions : allOptions -> string list -> string list * string list
  5.5331 +
  5.5332 +end
  5.5333 +
  5.5334 +(**** Original file: Options.sml ****)
  5.5335 +
  5.5336 +structure Metis = struct open Metis
  5.5337 +(* Metis-specific ML environment *)
  5.5338 +nonfix ++ -- RL mem union subset;
  5.5339 +val explode = String.explode;
  5.5340 +val implode = String.implode;
  5.5341 +val print = TextIO.print;
  5.5342 +(* ========================================================================= *)
  5.5343 +(* PROCESSING COMMAND LINE OPTIONS                                           *)
  5.5344 +(* Copyright (c) 2003-2004 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.5345 +(* ========================================================================= *)
  5.5346 +
  5.5347 +structure Options :> Options =
  5.5348 +struct
  5.5349 +
  5.5350 +infix ##
  5.5351 +
  5.5352 +open Useful;
  5.5353 +
  5.5354 +(* ------------------------------------------------------------------------- *)
  5.5355 +(* One command line option: names, arguments, description and a processor    *)
  5.5356 +(* ------------------------------------------------------------------------- *)
  5.5357 +
  5.5358 +type proc = string * string list -> unit;
  5.5359 +
  5.5360 +type ('a,'x) mkProc = ('x -> proc) -> ('a -> 'x) -> proc;
  5.5361 +
  5.5362 +type opt = {switches : string list, arguments : string list,
  5.5363 +            description : string, processor : proc};
  5.5364 +
  5.5365 +(* ------------------------------------------------------------------------- *)
  5.5366 +(* Option processors may raise an OptionExit exception                       *)
  5.5367 +(* ------------------------------------------------------------------------- *)
  5.5368 +
  5.5369 +type optionExit = {message : string option, usage : bool, success : bool};
  5.5370 +
  5.5371 +exception OptionExit of optionExit;
  5.5372 +
  5.5373 +(* ------------------------------------------------------------------------- *)
  5.5374 +(* Wrappers for option processors                                            *)
  5.5375 +(* ------------------------------------------------------------------------- *)
  5.5376 +
  5.5377 +fun beginOpt f p (s : string, l : string list) : unit = f (p s) (s,l);
  5.5378 +
  5.5379 +fun endOpt () (_ : string, [] : string list) = ()
  5.5380 +  | endOpt _ (_, _ :: _) = raise Bug "endOpt";
  5.5381 +
  5.5382 +fun stringOpt _ _ (_ : string, []) = raise Bug "stringOpt"
  5.5383 +  | stringOpt f p (s, (h : string) :: t) : unit = f (p h) (s,t);
  5.5384 +
  5.5385 +local
  5.5386 +  fun range NONE NONE = "Z"
  5.5387 +    | range (SOME i) NONE = "{n IN Z | " ^ Int.toString i ^ " <= n}"
  5.5388 +    | range NONE (SOME j) = "{n IN Z | n <= " ^ Int.toString j ^ "}"
  5.5389 +    | range (SOME i) (SOME j) =
  5.5390 +    "{n IN Z | " ^ Int.toString i ^ " <= n <= " ^ Int.toString j ^ "}";
  5.5391 +  fun oLeq (SOME x) (SOME y) = x <= y | oLeq _ _ = true;
  5.5392 +  fun argToInt arg omin omax x =
  5.5393 +    (case Int.fromString x of
  5.5394 +       SOME i =>
  5.5395 +       if oLeq omin (SOME i) andalso oLeq (SOME i) omax then i else
  5.5396 +         raise OptionExit
  5.5397 +           {success = false, usage = false, message =
  5.5398 +            SOME (arg ^ " option needs an integer argument in the range "
  5.5399 +                  ^ range omin omax ^ " (not " ^ x ^ ")")}
  5.5400 +     | NONE =>
  5.5401 +       raise OptionExit
  5.5402 +         {success = false, usage = false, message =
  5.5403 +          SOME (arg ^ " option needs an integer argument (not \"" ^ x ^ "\")")})
  5.5404 +    handle Overflow =>
  5.5405 +       raise OptionExit
  5.5406 +         {success = false, usage = false, message =
  5.5407 +          SOME (arg ^ " option suffered integer overflow on argument " ^ x)};
  5.5408 +in
  5.5409 +  fun intOpt _ _ _ (_,[]) = raise Bug "intOpt"
  5.5410 +    | intOpt (omin,omax) f p (s:string, h :: (t : string list)) : unit =
  5.5411 +      f (p (argToInt s omin omax h)) (s,t);
  5.5412 +end;
  5.5413 +
  5.5414 +local
  5.5415 +  fun range NONE NONE = "R"
  5.5416 +    | range (SOME i) NONE = "{n IN R | " ^ Real.toString i ^ " <= n}"
  5.5417 +    | range NONE (SOME j) = "{n IN R | n <= " ^ Real.toString j ^ "}"
  5.5418 +    | range (SOME i) (SOME j) =
  5.5419 +    "{n IN R | " ^ Real.toString i ^ " <= n <= " ^ Real.toString j ^ "}";
  5.5420 +  fun oLeq (SOME (x:real)) (SOME y) = x <= y | oLeq _ _ = true;
  5.5421 +  fun argToReal arg omin omax x =
  5.5422 +    (case Real.fromString x of
  5.5423 +       SOME i =>
  5.5424 +       if oLeq omin (SOME i) andalso oLeq (SOME i) omax then i else
  5.5425 +         raise OptionExit
  5.5426 +           {success = false, usage = false, message =
  5.5427 +            SOME (arg ^ " option needs an real argument in the range "
  5.5428 +                  ^ range omin omax ^ " (not " ^ x ^ ")")}
  5.5429 +     | NONE =>
  5.5430 +       raise OptionExit
  5.5431 +         {success = false, usage = false, message =
  5.5432 +          SOME (arg ^ " option needs an real argument (not \"" ^ x ^ "\")")})
  5.5433 +in
  5.5434 +  fun realOpt _ _ _ (_,[]) = raise Bug "realOpt"
  5.5435 +    | realOpt (omin,omax) f p (s:string, h :: (t : string list)) : unit =
  5.5436 +      f (p (argToReal s omin omax h)) (s,t);
  5.5437 +end;
  5.5438 +
  5.5439 +fun enumOpt _ _ _ (_,[]) = raise Bug "enumOpt"
  5.5440 +  | enumOpt (choices : string list) f p (s : string, h :: t) : unit =
  5.5441 +    if mem h choices then f (p h) (s,t) else
  5.5442 +      raise OptionExit
  5.5443 +        {success = false, usage = false,
  5.5444 +         message = SOME ("follow parameter " ^ s ^ " with one of {" ^
  5.5445 +                         join "," choices ^ "}, not \"" ^ h ^ "\"")};
  5.5446 +
  5.5447 +fun optionOpt _ _ _ (_,[]) = raise Bug "optionOpt"
  5.5448 +  | optionOpt (x : string, p) f q (s : string, l as h :: t) : unit =
  5.5449 +    if h = x then f (q NONE) (s,t) else p f (q o SOME) (s,l);
  5.5450 +
  5.5451 +(* ------------------------------------------------------------------------- *)
  5.5452 +(* Basic options useful for all programs                                     *)
  5.5453 +(* ------------------------------------------------------------------------- *)
  5.5454 +
  5.5455 +val basicOptions : opt list =
  5.5456 +  [{switches = ["--"], arguments = [],
  5.5457 +    description = "no more options",
  5.5458 +    processor = fn _ => raise Fail "basicOptions: --"},
  5.5459 +   {switches = ["--verbose"], arguments = ["0..10"],
  5.5460 +    description = "the degree of verbosity",
  5.5461 +    processor = intOpt (SOME 0, SOME 10) endOpt (fn i => traceLevel := i)},
  5.5462 +   {switches = ["--secret"], arguments = [],
  5.5463 +    description = "process then hide the next option",
  5.5464 +    processor = fn _ => raise Fail "basicOptions: --secret"},
  5.5465 +   {switches = ["-?","-h","--help"], arguments = [],
  5.5466 +    description = "display all options and exit",
  5.5467 +    processor = fn _ => raise OptionExit
  5.5468 +    {message = SOME "displaying all options", usage = true, success = true}},
  5.5469 +   {switches = ["-v", "--version"], arguments = [],
  5.5470 +    description = "display version information",
  5.5471 +    processor = fn _ => raise Fail "basicOptions: -v, --version"}];
  5.5472 +
  5.5473 +(* ------------------------------------------------------------------------- *)
  5.5474 +(* All the command line options of a program                                 *)
  5.5475 +(* ------------------------------------------------------------------------- *)
  5.5476 +
  5.5477 +type allOptions = {name : string, version : string, header : string,
  5.5478 +                   footer : string, options : opt list};
  5.5479 +
  5.5480 +(* ------------------------------------------------------------------------- *)
  5.5481 +(* Usage information                                                         *)
  5.5482 +(* ------------------------------------------------------------------------- *)
  5.5483 +
  5.5484 +fun versionInformation ({version, ...} : allOptions) = version;
  5.5485 +
  5.5486 +fun usageInformation ({name,version,header,footer,options} : allOptions) =
  5.5487 +  let
  5.5488 +    fun filt ["--verbose"] = false
  5.5489 +      | filt ["--secret"] = false
  5.5490 +      | filt _ = true
  5.5491 +
  5.5492 +    fun listOpts {switches = n, arguments = r, description = s,
  5.5493 +                  processor = _} =
  5.5494 +        let
  5.5495 +          fun indent (s, "" :: l) = indent (s ^ "  ", l) | indent x = x
  5.5496 +          val (res,n) = indent ("  ",n)
  5.5497 +          val res = res ^ join ", " n
  5.5498 +          val res = foldl (fn (x,y) => y ^ " " ^ x) res r
  5.5499 +        in
  5.5500 +          [res ^ " ...", " " ^ s]
  5.5501 +        end
  5.5502 +
  5.5503 +    val options = List.filter (filt o #switches) options
  5.5504 +
  5.5505 +    val alignment =
  5.5506 +        [{leftAlign = true, padChar = #"."},
  5.5507 +         {leftAlign = true, padChar = #" "}]
  5.5508 +
  5.5509 +    val table = alignTable alignment (map listOpts options)
  5.5510 +  in
  5.5511 +    header ^ join "\n" table ^ "\n" ^ footer
  5.5512 +  end;
  5.5513 +
  5.5514 +(* ------------------------------------------------------------------------- *)
  5.5515 +(* Exit the program gracefully                                               *)
  5.5516 +(* ------------------------------------------------------------------------- *)
  5.5517 +
  5.5518 +fun exit (allopts : allOptions) (optexit : optionExit) =
  5.5519 +  let
  5.5520 +    val {name, options, ...} = allopts
  5.5521 +    val {message, usage, success} = optexit
  5.5522 +    fun err s = TextIO.output (TextIO.stdErr, s)
  5.5523 +  in
  5.5524 +    case message of NONE => () | SOME m => err (name ^ ": " ^ m ^ "\n");
  5.5525 +    if usage then err (usageInformation allopts) else ();
  5.5526 +    OS.Process.exit (if success then OS.Process.success else OS.Process.failure)
  5.5527 +  end;
  5.5528 +
  5.5529 +fun succeed allopts =
  5.5530 +    exit allopts {message = NONE, usage = false, success = true};
  5.5531 +
  5.5532 +fun fail allopts mesg =
  5.5533 +    exit allopts {message = SOME mesg, usage = false, success = false};
  5.5534 +
  5.5535 +fun usage allopts mesg =
  5.5536 +    exit allopts {message = SOME mesg, usage = true, success = false};
  5.5537 +
  5.5538 +fun version allopts =
  5.5539 +    (print (versionInformation allopts);
  5.5540 +     exit allopts {message = NONE, usage = false, success = true});
  5.5541 +
  5.5542 +(* ------------------------------------------------------------------------- *)
  5.5543 +(* Process the command line options passed to the program                    *)
  5.5544 +(* ------------------------------------------------------------------------- *)
  5.5545 +
  5.5546 +fun processOptions (allopts : allOptions) =
  5.5547 +  let
  5.5548 +    fun findOption x =
  5.5549 +      case List.find (fn {switches = n, ...} => mem x n) (#options allopts) of
  5.5550 +        NONE => raise OptionExit
  5.5551 +                        {message = SOME ("unknown switch \"" ^ x ^ "\""),
  5.5552 +                         usage = true, success = false}
  5.5553 +      | SOME {arguments = r, processor = f, ...} => (r,f)
  5.5554 +
  5.5555 +    fun getArgs x r xs =
  5.5556 +      let
  5.5557 +        fun f 1 = "a following argument"
  5.5558 +          | f m = Int.toString m ^ " following arguments"
  5.5559 +        val m = length r
  5.5560 +        val () =
  5.5561 +          if m <= length xs then () else
  5.5562 +            raise OptionExit
  5.5563 +              {usage = false, success = false, message = SOME
  5.5564 +               (x ^ " option needs " ^ f m ^ ": " ^ join " " r)}
  5.5565 +      in
  5.5566 +        divide xs m
  5.5567 +      end
  5.5568 +
  5.5569 +    fun process [] = ([], [])
  5.5570 +      | process ("--" :: xs) = ([("--",[])], xs)
  5.5571 +      | process ("--secret" :: xs) = (tl ## I) (process xs)
  5.5572 +      | process ("-v" :: _) = version allopts
  5.5573 +      | process ("--version" :: _) = version allopts
  5.5574 +      | process (x :: xs) =
  5.5575 +      if x = "" orelse x = "-" orelse hd (explode x) <> #"-" then ([], x :: xs)
  5.5576 +      else
  5.5577 +        let
  5.5578 +          val (r,f) = findOption x
  5.5579 +          val (ys,xs) = getArgs x r xs
  5.5580 +          val () = f (x,ys)
  5.5581 +        in
  5.5582 +          (cons (x,ys) ## I) (process xs)
  5.5583 +        end
  5.5584 +  in
  5.5585 +    fn l =>
  5.5586 +    let
  5.5587 +      val (a,b) = process l
  5.5588 +      val a = foldl (fn ((x,xs),ys) => x :: xs @ ys) [] (rev a)
  5.5589 +    in
  5.5590 +      (a,b)
  5.5591 +    end
  5.5592 +    handle OptionExit x => exit allopts x
  5.5593 +  end;
  5.5594 +
  5.5595 +end
  5.5596 +end;
  5.5597 +
  5.5598 +(**** Original file: Name.sig ****)
  5.5599 +
  5.5600 +(* ========================================================================= *)
  5.5601 +(* NAMES                                                                     *)
  5.5602 +(* Copyright (c) 2004-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.5603 +(* ========================================================================= *)
  5.5604 +
  5.5605 +signature Name =
  5.5606 +sig
  5.5607 +
  5.5608 +type name = string
  5.5609 +
  5.5610 +val compare : name * name -> order
  5.5611 +
  5.5612 +val pp : name Metis.Parser.pp
  5.5613 +
  5.5614 +end
  5.5615 +
  5.5616 +(**** Original file: Name.sml ****)
  5.5617 +
  5.5618 +structure Metis = struct open Metis
  5.5619 +(* Metis-specific ML environment *)
  5.5620 +nonfix ++ -- RL mem union subset;
  5.5621 +val explode = String.explode;
  5.5622 +val implode = String.implode;
  5.5623 +val print = TextIO.print;
  5.5624 +(* ========================================================================= *)
  5.5625 +(* NAMES                                                                     *)
  5.5626 +(* Copyright (c) 2004-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.5627 +(* ========================================================================= *)
  5.5628 +
  5.5629 +structure Name :> Name =
  5.5630 +struct
  5.5631 +
  5.5632 +type name = string;
  5.5633 +
  5.5634 +val compare = String.compare;
  5.5635 +
  5.5636 +val pp = Parser.ppString;
  5.5637 +
  5.5638 +end
  5.5639 +
  5.5640 +structure NameOrdered =
  5.5641 +struct type t = Name.name val compare = Name.compare end
  5.5642 +
  5.5643 +structure NameSet =
  5.5644 +struct
  5.5645 +
  5.5646 +  local
  5.5647 +    structure S = ElementSet (NameOrdered);
  5.5648 +  in
  5.5649 +    open S;
  5.5650 +  end;
  5.5651 +
  5.5652 +  val pp =
  5.5653 +      Parser.ppMap
  5.5654 +        toList
  5.5655 +        (Parser.ppBracket "{" "}" (Parser.ppSequence "," Name.pp));
  5.5656 +
  5.5657 +end
  5.5658 +
  5.5659 +structure NameMap = KeyMap (NameOrdered);
  5.5660 +
  5.5661 +structure NameArity =
  5.5662 +struct
  5.5663 +
  5.5664 +type nameArity = Name.name * int;
  5.5665 +
  5.5666 +fun name ((n,_) : nameArity) = n;
  5.5667 +
  5.5668 +fun arity ((_,i) : nameArity) = i;
  5.5669 +
  5.5670 +fun nary i n_i = arity n_i = i;
  5.5671 +
  5.5672 +val nullary = nary 0
  5.5673 +and unary = nary 1
  5.5674 +and binary = nary 2
  5.5675 +and ternary = nary 3;
  5.5676 +
  5.5677 +fun compare ((n1,i1),(n2,i2)) =
  5.5678 +    case Name.compare (n1,n2) of
  5.5679 +      LESS => LESS
  5.5680 +    | EQUAL => Int.compare (i1,i2)
  5.5681 +    | GREATER => GREATER;
  5.5682 +
  5.5683 +val pp = Parser.ppMap (fn (n,i) => n ^ "/" ^ Int.toString i) Parser.ppString;
  5.5684 +
  5.5685 +end
  5.5686 +
  5.5687 +structure NameArityOrdered =
  5.5688 +struct type t = NameArity.nameArity val compare = NameArity.compare end
  5.5689 +
  5.5690 +structure NameAritySet =
  5.5691 +struct
  5.5692 +
  5.5693 +  local
  5.5694 +    structure S = ElementSet (NameArityOrdered);
  5.5695 +  in
  5.5696 +    open S;
  5.5697 +  end;
  5.5698 +
  5.5699 +  val allNullary = all NameArity.nullary;
  5.5700 +
  5.5701 +  val pp =
  5.5702 +      Parser.ppMap
  5.5703 +        toList
  5.5704 +        (Parser.ppBracket "{" "}" (Parser.ppSequence "," NameArity.pp));
  5.5705 +
  5.5706 +end
  5.5707 +
  5.5708 +structure NameArityMap = KeyMap (NameArityOrdered);
  5.5709 +end;
  5.5710 +
  5.5711 +(**** Original file: Term.sig ****)
  5.5712 +
  5.5713 +(* ========================================================================= *)
  5.5714 +(* FIRST ORDER LOGIC TERMS                                                   *)
  5.5715 +(* Copyright (c) 2001-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.5716 +(* ========================================================================= *)
  5.5717 +
  5.5718 +signature Term =
  5.5719 +sig
  5.5720 +
  5.5721 +(* ------------------------------------------------------------------------- *)
  5.5722 +(* A type of first order logic terms.                                        *)
  5.5723 +(* ------------------------------------------------------------------------- *)
  5.5724 +
  5.5725 +type var = Metis.Name.name
  5.5726 +
  5.5727 +type functionName = Metis.Name.name
  5.5728 +
  5.5729 +type function = functionName * int
  5.5730 +
  5.5731 +type const = functionName
  5.5732 +
  5.5733 +datatype term =
  5.5734 +    Var of var
  5.5735 +  | Fn of functionName * term list
  5.5736 +
  5.5737 +(* ------------------------------------------------------------------------- *)
  5.5738 +(* Constructors and destructors.                                             *)
  5.5739 +(* ------------------------------------------------------------------------- *)
  5.5740 +
  5.5741 +(* Variables *)
  5.5742 +
  5.5743 +val destVar : term -> var
  5.5744 +
  5.5745 +val isVar : term -> bool
  5.5746 +
  5.5747 +val equalVar : var -> term -> bool
  5.5748 +
  5.5749 +(* Functions *)
  5.5750 +
  5.5751 +val destFn : term -> functionName * term list
  5.5752 +
  5.5753 +val isFn : term -> bool
  5.5754 +
  5.5755 +val fnName : term -> functionName
  5.5756 +
  5.5757 +val fnArguments : term -> term list
  5.5758 +
  5.5759 +val fnArity : term -> int
  5.5760 +
  5.5761 +val fnFunction : term -> function
  5.5762 +
  5.5763 +val functions : term -> Metis.NameAritySet.set
  5.5764 +
  5.5765 +val functionNames : term -> Metis.NameSet.set
  5.5766 +
  5.5767 +(* Constants *)
  5.5768 +
  5.5769 +val mkConst : const -> term
  5.5770 +
  5.5771 +val destConst : term -> const
  5.5772 +
  5.5773 +val isConst : term -> bool
  5.5774 +
  5.5775 +(* Binary functions *)
  5.5776 +
  5.5777 +val mkBinop : functionName -> term * term -> term
  5.5778 +
  5.5779 +val destBinop : functionName -> term -> term * term
  5.5780 +
  5.5781 +val isBinop : functionName -> term -> bool
  5.5782 +
  5.5783 +(* ------------------------------------------------------------------------- *)
  5.5784 +(* The size of a term in symbols.                                            *)
  5.5785 +(* ------------------------------------------------------------------------- *)
  5.5786 +
  5.5787 +val symbols : term -> int
  5.5788 +
  5.5789 +(* ------------------------------------------------------------------------- *)
  5.5790 +(* A total comparison function for terms.                                    *)
  5.5791 +(* ------------------------------------------------------------------------- *)
  5.5792 +
  5.5793 +val compare : term * term -> order
  5.5794 +
  5.5795 +(* ------------------------------------------------------------------------- *)
  5.5796 +(* Subterms.                                                                 *)
  5.5797 +(* ------------------------------------------------------------------------- *)
  5.5798 +
  5.5799 +type path = int list
  5.5800 +
  5.5801 +val subterm : term -> path -> term
  5.5802 +
  5.5803 +val subterms : term -> (path * term) list
  5.5804 +
  5.5805 +val replace : term -> path * term -> term
  5.5806 +
  5.5807 +val find : (term -> bool) -> term -> path option
  5.5808 +
  5.5809 +val ppPath : path Metis.Parser.pp
  5.5810 +
  5.5811 +val pathToString : path -> string
  5.5812 +
  5.5813 +(* ------------------------------------------------------------------------- *)
  5.5814 +(* Free variables.                                                           *)
  5.5815 +(* ------------------------------------------------------------------------- *)
  5.5816 +
  5.5817 +val freeIn : var -> term -> bool
  5.5818 +
  5.5819 +val freeVars : term -> Metis.NameSet.set
  5.5820 +
  5.5821 +(* ------------------------------------------------------------------------- *)
  5.5822 +(* Fresh variables.                                                          *)
  5.5823 +(* ------------------------------------------------------------------------- *)
  5.5824 +
  5.5825 +val newVar : unit -> term
  5.5826 +
  5.5827 +val newVars : int -> term list
  5.5828 +
  5.5829 +val variantPrime : Metis.NameSet.set -> var -> var
  5.5830 +
  5.5831 +val variantNum : Metis.NameSet.set -> var -> var
  5.5832 +
  5.5833 +(* ------------------------------------------------------------------------- *)
  5.5834 +(* Special support for terms with type annotations.                          *)
  5.5835 +(* ------------------------------------------------------------------------- *)
  5.5836 +
  5.5837 +val isTypedVar : term -> bool
  5.5838 +
  5.5839 +val typedSymbols : term -> int
  5.5840 +
  5.5841 +val nonVarTypedSubterms : term -> (path * term) list
  5.5842 +
  5.5843 +(* ------------------------------------------------------------------------- *)
  5.5844 +(* Special support for terms with an explicit function application operator. *)
  5.5845 +(* ------------------------------------------------------------------------- *)
  5.5846 +
  5.5847 +val mkComb : term * term -> term
  5.5848 +
  5.5849 +val destComb : term -> term * term
  5.5850 +
  5.5851 +val isComb : term -> bool
  5.5852 +
  5.5853 +val listMkComb : term * term list -> term
  5.5854 +
  5.5855 +val stripComb : term -> term * term list
  5.5856 +
  5.5857 +(* ------------------------------------------------------------------------- *)
  5.5858 +(* Parsing and pretty printing.                                              *)
  5.5859 +(* ------------------------------------------------------------------------- *)
  5.5860 +
  5.5861 +(* Infix symbols *)
  5.5862 +
  5.5863 +val infixes : Metis.Parser.infixities ref
  5.5864 +
  5.5865 +(* The negation symbol *)
  5.5866 +
  5.5867 +val negation : Metis.Name.name ref
  5.5868 +
  5.5869 +(* Binder symbols *)
  5.5870 +
  5.5871 +val binders : Metis.Name.name list ref
  5.5872 +
  5.5873 +(* Bracket symbols *)
  5.5874 +
  5.5875 +val brackets : (Metis.Name.name * Metis.Name.name) list ref
  5.5876 +
  5.5877 +(* Pretty printing *)
  5.5878 +
  5.5879 +val pp : term Metis.Parser.pp
  5.5880 +
  5.5881 +val toString : term -> string
  5.5882 +
  5.5883 +(* Parsing *)
  5.5884 +
  5.5885 +val fromString : string -> term
  5.5886 +
  5.5887 +val parse : term Metis.Parser.quotation -> term
  5.5888 +
  5.5889 +end
  5.5890 +
  5.5891 +(**** Original file: Term.sml ****)
  5.5892 +
  5.5893 +structure Metis = struct open Metis
  5.5894 +(* Metis-specific ML environment *)
  5.5895 +nonfix ++ -- RL mem union subset;
  5.5896 +val explode = String.explode;
  5.5897 +val implode = String.implode;
  5.5898 +val print = TextIO.print;
  5.5899 +(* ========================================================================= *)
  5.5900 +(* FIRST ORDER LOGIC TERMS                                                   *)
  5.5901 +(* Copyright (c) 2001-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.5902 +(* ========================================================================= *)
  5.5903 +
  5.5904 +structure Term :> Term =
  5.5905 +struct
  5.5906 +
  5.5907 +open Useful;
  5.5908 +
  5.5909 +(* ------------------------------------------------------------------------- *)
  5.5910 +(* Helper functions.                                                         *)
  5.5911 +(* ------------------------------------------------------------------------- *)
  5.5912 +
  5.5913 +fun stripSuffix pred s =
  5.5914 +    let
  5.5915 +      fun f 0 = ""
  5.5916 +        | f n =
  5.5917 +          let
  5.5918 +            val n' = n - 1
  5.5919 +          in
  5.5920 +            if pred (String.sub (s,n')) then f n'
  5.5921 +            else String.substring (s,0,n)
  5.5922 +          end
  5.5923 +    in
  5.5924 +      f (size s)
  5.5925 +    end;
  5.5926 +
  5.5927 +(* ------------------------------------------------------------------------- *)
  5.5928 +(* A type of first order logic terms.                                        *)
  5.5929 +(* ------------------------------------------------------------------------- *)
  5.5930 +
  5.5931 +type var = Name.name;
  5.5932 +
  5.5933 +type functionName = Name.name;
  5.5934 +
  5.5935 +type function = functionName * int;
  5.5936 +
  5.5937 +type const = functionName;
  5.5938 +
  5.5939 +datatype term =
  5.5940 +    Var of Name.name
  5.5941 +  | Fn of Name.name * term list;
  5.5942 +
  5.5943 +(* ------------------------------------------------------------------------- *)
  5.5944 +(* Constructors and destructors.                                             *)
  5.5945 +(* ------------------------------------------------------------------------- *)
  5.5946 +
  5.5947 +(* Variables *)
  5.5948 +
  5.5949 +fun destVar (Var v) = v
  5.5950 +  | destVar (Fn _) = raise Error "destVar";
  5.5951 +
  5.5952 +val isVar = can destVar;
  5.5953 +
  5.5954 +fun equalVar v (Var v') = v = v'
  5.5955 +  | equalVar _ _ = false;
  5.5956 +
  5.5957 +(* Functions *)
  5.5958 +
  5.5959 +fun destFn (Fn f) = f
  5.5960 +  | destFn (Var _) = raise Error "destFn";
  5.5961 +
  5.5962 +val isFn = can destFn;
  5.5963 +
  5.5964 +fun fnName tm = fst (destFn tm);
  5.5965 +
  5.5966 +fun fnArguments tm = snd (destFn tm);
  5.5967 +
  5.5968 +fun fnArity tm = length (fnArguments tm);
  5.5969 +
  5.5970 +fun fnFunction tm = (fnName tm, fnArity tm);
  5.5971 +
  5.5972 +local
  5.5973 +  fun func fs [] = fs
  5.5974 +    | func fs (Var _ :: tms) = func fs tms
  5.5975 +    | func fs (Fn (n,l) :: tms) =
  5.5976 +      func (NameAritySet.add fs (n, length l)) (l @ tms);
  5.5977 +in
  5.5978 +  fun functions tm = func NameAritySet.empty [tm];
  5.5979 +end;
  5.5980 +
  5.5981 +local
  5.5982 +  fun func fs [] = fs
  5.5983 +    | func fs (Var _ :: tms) = func fs tms
  5.5984 +    | func fs (Fn (n,l) :: tms) = func (NameSet.add fs n) (l @ tms);
  5.5985 +in
  5.5986 +  fun functionNames tm = func NameSet.empty [tm];
  5.5987 +end;
  5.5988 +
  5.5989 +(* Constants *)
  5.5990 +
  5.5991 +fun mkConst c = (Fn (c, []));
  5.5992 +
  5.5993 +fun destConst (Fn (c, [])) = c
  5.5994 +  | destConst _ = raise Error "destConst";
  5.5995 +
  5.5996 +val isConst = can destConst;
  5.5997 +
  5.5998 +(* Binary functions *)
  5.5999 +
  5.6000 +fun mkBinop f (a,b) = Fn (f,[a,b]);
  5.6001 +
  5.6002 +fun destBinop f (Fn (x,[a,b])) =
  5.6003 +    if x = f then (a,b) else raise Error "Term.destBinop: wrong binop"
  5.6004 +  | destBinop _ _ = raise Error "Term.destBinop: not a binop";
  5.6005 +
  5.6006 +fun isBinop f = can (destBinop f);
  5.6007 +
  5.6008 +(* ------------------------------------------------------------------------- *)
  5.6009 +(* The size of a term in symbols.                                            *)
  5.6010 +(* ------------------------------------------------------------------------- *)
  5.6011 +
  5.6012 +local
  5.6013 +  fun sz n [] = n
  5.6014 +    | sz n (Var _ :: tms) = sz (n + 1) tms
  5.6015 +    | sz n (Fn (_,args) :: tms) = sz (n + 1) (args @ tms);
  5.6016 +in
  5.6017 +  fun symbols tm = sz 0 [tm];
  5.6018 +end;
  5.6019 +
  5.6020 +(* ------------------------------------------------------------------------- *)
  5.6021 +(* A total comparison function for terms.                                    *)
  5.6022 +(* ------------------------------------------------------------------------- *)
  5.6023 +
  5.6024 +local
  5.6025 +  fun cmp [] [] = EQUAL
  5.6026 +    | cmp (Var _ :: _) (Fn _ :: _) = LESS
  5.6027 +    | cmp (Fn _ :: _) (Var _ :: _) = GREATER
  5.6028 +    | cmp (Var v1 :: tms1) (Var v2 :: tms2) =
  5.6029 +      (case Name.compare (v1,v2) of
  5.6030 +         LESS => LESS
  5.6031 +       | EQUAL => cmp tms1 tms2
  5.6032 +       | GREATER => GREATER)
  5.6033 +    | cmp (Fn (f1,a1) :: tms1) (Fn (f2,a2) :: tms2) =
  5.6034 +      (case Name.compare (f1,f2) of
  5.6035 +         LESS => LESS
  5.6036 +       | EQUAL =>
  5.6037 +         (case Int.compare (length a1, length a2) of
  5.6038 +            LESS => LESS
  5.6039 +          | EQUAL => cmp (a1 @ tms1) (a2 @ tms2)
  5.6040 +          | GREATER => GREATER)
  5.6041 +       | GREATER => GREATER)
  5.6042 +    | cmp _ _ = raise Bug "Term.compare";
  5.6043 +in
  5.6044 +  fun compare (tm1,tm2) = cmp [tm1] [tm2];
  5.6045 +end;
  5.6046 +
  5.6047 +(* ------------------------------------------------------------------------- *)
  5.6048 +(* Subterms.                                                                 *)
  5.6049 +(* ------------------------------------------------------------------------- *)
  5.6050 +
  5.6051 +type path = int list;
  5.6052 +
  5.6053 +fun subterm tm [] = tm
  5.6054 +  | subterm (Var _) (_ :: _) = raise Error "Term.subterm: Var"
  5.6055 +  | subterm (Fn (_,tms)) (h :: t) =
  5.6056 +    if h >= length tms then raise Error "Term.replace: Fn"
  5.6057 +    else subterm (List.nth (tms,h)) t;
  5.6058 +
  5.6059 +local
  5.6060 +  fun subtms [] acc = acc
  5.6061 +    | subtms ((path,tm) :: rest) acc =
  5.6062 +      let
  5.6063 +        fun f (n,arg) = (n :: path, arg)
  5.6064 +
  5.6065 +        val acc = (rev path, tm) :: acc
  5.6066 +      in
  5.6067 +        case tm of
  5.6068 +          Var _ => subtms rest acc
  5.6069 +        | Fn (_,args) => subtms (map f (enumerate args) @ rest) acc
  5.6070 +      end;
  5.6071 +in
  5.6072 +  fun subterms tm = subtms [([],tm)] [];
  5.6073 +end;
  5.6074 +
  5.6075 +fun replace tm ([],res) = if res = tm then tm else res
  5.6076 +  | replace tm (h :: t, res) =
  5.6077 +    case tm of
  5.6078 +      Var _ => raise Error "Term.replace: Var"
  5.6079 +    | Fn (func,tms) =>
  5.6080 +      if h >= length tms then raise Error "Term.replace: Fn"
  5.6081 +      else
  5.6082 +        let
  5.6083 +          val arg = List.nth (tms,h)
  5.6084 +          val arg' = replace arg (t,res)
  5.6085 +        in
  5.6086 +          if Sharing.pointerEqual (arg',arg) then tm
  5.6087 +          else Fn (func, updateNth (h,arg') tms)
  5.6088 +        end;
  5.6089 +
  5.6090 +fun find pred =
  5.6091 +    let
  5.6092 +      fun search [] = NONE
  5.6093 +        | search ((path,tm) :: rest) =
  5.6094 +          if pred tm then SOME (rev path)
  5.6095 +          else
  5.6096 +            case tm of
  5.6097 +              Var _ => search rest
  5.6098 +            | Fn (_,a) =>
  5.6099 +              let
  5.6100 +                val subtms = map (fn (i,t) => (i :: path, t)) (enumerate a)
  5.6101 +              in
  5.6102 +                search (subtms @ rest)
  5.6103 +              end
  5.6104 +    in
  5.6105 +      fn tm => search [([],tm)]
  5.6106 +    end;
  5.6107 +
  5.6108 +val ppPath = Parser.ppList Parser.ppInt;
  5.6109 +
  5.6110 +val pathToString = Parser.toString ppPath;
  5.6111 +
  5.6112 +(* ------------------------------------------------------------------------- *)
  5.6113 +(* Free variables.                                                           *)
  5.6114 +(* ------------------------------------------------------------------------- *)
  5.6115 +
  5.6116 +local
  5.6117 +  fun free _ [] = false
  5.6118 +    | free v (Var w :: tms) = v = w orelse free v tms
  5.6119 +    | free v (Fn (_,args) :: tms) = free v (args @ tms);
  5.6120 +in
  5.6121 +  fun freeIn v tm = free v [tm];
  5.6122 +end;
  5.6123 +
  5.6124 +local
  5.6125 +  fun free vs [] = vs
  5.6126 +    | free vs (Var v :: tms) = free (NameSet.add vs v) tms
  5.6127 +    | free vs (Fn (_,args) :: tms) = free vs (args @ tms);
  5.6128 +in
  5.6129 +  fun freeVars tm = free NameSet.empty [tm];
  5.6130 +end;
  5.6131 +
  5.6132 +(* ------------------------------------------------------------------------- *)
  5.6133 +(* Fresh variables.                                                          *)
  5.6134 +(* ------------------------------------------------------------------------- *)
  5.6135 +
  5.6136 +local
  5.6137 +  val prefix  = "_";
  5.6138 +
  5.6139 +  fun numVar i = Var (mkPrefix prefix (Int.toString i));
  5.6140 +in
  5.6141 +  fun newVar () = numVar (newInt ());
  5.6142 +
  5.6143 +  fun newVars n = map numVar (newInts n);
  5.6144 +end;
  5.6145 +
  5.6146 +fun variantPrime avoid =
  5.6147 +    let
  5.6148 +      fun f v = if NameSet.member v avoid then f (v ^ "'") else v
  5.6149 +    in
  5.6150 +      f
  5.6151 +    end;
  5.6152 +
  5.6153 +fun variantNum avoid v =
  5.6154 +    if not (NameSet.member v avoid) then v
  5.6155 +    else
  5.6156 +      let
  5.6157 +        val v = stripSuffix Char.isDigit v
  5.6158 +                                                                    
  5.6159 +        fun f n =
  5.6160 +            let
  5.6161 +              val v_n = v ^ Int.toString n
  5.6162 +            in
  5.6163 +              if NameSet.member v_n avoid then f (n + 1) else v_n
  5.6164 +            end
  5.6165 +      in
  5.6166 +        f 0
  5.6167 +      end;
  5.6168 +
  5.6169 +(* ------------------------------------------------------------------------- *)
  5.6170 +(* Special support for terms with type annotations.                          *)
  5.6171 +(* ------------------------------------------------------------------------- *)
  5.6172 +
  5.6173 +fun isTypedVar (Var _) = true
  5.6174 +  | isTypedVar (Fn (":", [Var _, _])) = true
  5.6175 +  | isTypedVar (Fn _) = false;
  5.6176 +
  5.6177 +local
  5.6178 +  fun sz n [] = n
  5.6179 +    | sz n (Var _ :: tms) = sz (n + 1) tms
  5.6180 +    | sz n (Fn (":",[tm,_]) :: tms) = sz n (tm :: tms)
  5.6181 +    | sz n (Fn (_,args) :: tms) = sz (n + 1) (args @ tms);
  5.6182 +in
  5.6183 +  fun typedSymbols tm = sz 0 [tm];
  5.6184 +end;
  5.6185 +
  5.6186 +local
  5.6187 +  fun subtms [] acc = acc
  5.6188 +    | subtms ((_, Var _) :: rest) acc = subtms rest acc
  5.6189 +    | subtms ((_, Fn (":", [Var _, _])) :: rest) acc = subtms rest acc
  5.6190 +    | subtms ((path, tm as Fn func) :: rest) acc =
  5.6191 +      let
  5.6192 +        fun f (n,arg) = (n :: path, arg)
  5.6193 +
  5.6194 +        val acc = (rev path, tm) :: acc
  5.6195 +      in
  5.6196 +        case func of
  5.6197 +          (":",[arg,_]) => subtms ((0 :: path, arg) :: rest) acc
  5.6198 +        | (_,args) => subtms (map f (enumerate args) @ rest) acc
  5.6199 +      end;
  5.6200 +in
  5.6201 +  fun nonVarTypedSubterms tm = subtms [([],tm)] [];
  5.6202 +end;
  5.6203 +
  5.6204 +(* ------------------------------------------------------------------------- *)
  5.6205 +(* Special support for terms with an explicit function application operator. *)
  5.6206 +(* ------------------------------------------------------------------------- *)
  5.6207 +
  5.6208 +fun mkComb (f,a) = Fn (".",[f,a]);
  5.6209 +
  5.6210 +fun destComb (Fn (".",[f,a])) = (f,a)
  5.6211 +  | destComb _ = raise Error "destComb";
  5.6212 +
  5.6213 +val isComb = can destComb;
  5.6214 +
  5.6215 +fun listMkComb (f,l) = foldl mkComb f l;
  5.6216 +
  5.6217 +local
  5.6218 +  fun strip tms (Fn (".",[f,a])) = strip (a :: tms) f
  5.6219 +    | strip tms tm = (tm,tms);
  5.6220 +in
  5.6221 +  fun stripComb tm = strip [] tm;
  5.6222 +end;
  5.6223 +
  5.6224 +(* ------------------------------------------------------------------------- *)
  5.6225 +(* Parsing and pretty printing.                                              *)
  5.6226 +(* ------------------------------------------------------------------------- *)
  5.6227 +
  5.6228 +(* Operators parsed and printed infix *)
  5.6229 +
  5.6230 +val infixes : Parser.infixities ref = ref
  5.6231 +  [(* ML symbols *)
  5.6232 +   {token = " / ", precedence = 7, leftAssoc = true},
  5.6233 +   {token = " div ", precedence = 7, leftAssoc = true},
  5.6234 +   {token = " mod ", precedence = 7, leftAssoc = true},
  5.6235 +   {token = " * ", precedence = 7, leftAssoc = true},
  5.6236 +   {token = " + ", precedence = 6, leftAssoc = true},
  5.6237 +   {token = " - ", precedence = 6, leftAssoc = true},
  5.6238 +   {token = " ^ ", precedence = 6, leftAssoc = true},
  5.6239 +   {token = " @ ", precedence = 5, leftAssoc = false},
  5.6240 +   {token = " :: ", precedence = 5, leftAssoc = false},
  5.6241 +   {token = " = ", precedence = 4, leftAssoc = true},
  5.6242 +   {token = " <> ", precedence = 4, leftAssoc = true},
  5.6243 +   {token = " <= ", precedence = 4, leftAssoc = true},
  5.6244 +   {token = " < ", precedence = 4, leftAssoc = true},
  5.6245 +   {token = " >= ", precedence = 4, leftAssoc = true},
  5.6246 +   {token = " > ", precedence = 4, leftAssoc = true},
  5.6247 +   {token = " o ", precedence = 3, leftAssoc = true},
  5.6248 +   {token = " -> ", precedence = 2, leftAssoc = false},  (* inferred prec *)
  5.6249 +   {token = " : ", precedence = 1, leftAssoc = false},  (* inferred prec *)
  5.6250 +   {token = ", ", precedence = 0, leftAssoc = false},  (* inferred prec *)
  5.6251 +
  5.6252 +   (* Logical connectives *)
  5.6253 +   {token = " /\\ ", precedence = ~1, leftAssoc = false},
  5.6254 +   {token = " \\/ ", precedence = ~2, leftAssoc = false},
  5.6255 +   {token = " ==> ", precedence = ~3, leftAssoc = false},
  5.6256 +   {token = " <=> ", precedence = ~4, leftAssoc = false},
  5.6257 +
  5.6258 +   (* Other symbols *)
  5.6259 +   {token = " . ", precedence = 9, leftAssoc = true},  (* function app *)
  5.6260 +   {token = " ** ", precedence = 8, leftAssoc = true},
  5.6261 +   {token = " ++ ", precedence = 6, leftAssoc = true},
  5.6262 +   {token = " -- ", precedence = 6, leftAssoc = true},
  5.6263 +   {token = " == ", precedence = 4, leftAssoc = true}];
  5.6264 +
  5.6265 +(* The negation symbol *)
  5.6266 +
  5.6267 +val negation : Name.name ref = ref "~";
  5.6268 +
  5.6269 +(* Binder symbols *)
  5.6270 +
  5.6271 +val binders : Name.name list ref = ref ["\\","!","?","?!"];
  5.6272 +
  5.6273 +(* Bracket symbols *)
  5.6274 +
  5.6275 +val brackets : (Name.name * Name.name) list ref = ref [("[","]"),("{","}")];
  5.6276 +
  5.6277 +(* Pretty printing *)
  5.6278 +
  5.6279 +local
  5.6280 +  open Parser;
  5.6281 +in
  5.6282 +  fun pp inputPpstrm inputTerm =
  5.6283 +      let
  5.6284 +        val quants = !binders
  5.6285 +        and iOps = !infixes
  5.6286 +        and neg = !negation
  5.6287 +        and bracks = !brackets
  5.6288 +
  5.6289 +        val bracks = map (fn (b1,b2) => (b1 ^ b2, b1, b2)) bracks
  5.6290 +
  5.6291 +        val bTokens = map #2 bracks @ map #3 bracks
  5.6292 +
  5.6293 +        val iTokens = infixTokens iOps
  5.6294 +
  5.6295 +        fun destI (Fn (f,[a,b])) =
  5.6296 +            if mem f iTokens then SOME (f,a,b) else NONE
  5.6297 +          | destI _ = NONE
  5.6298 +
  5.6299 +        val iPrinter = ppInfixes iOps destI
  5.6300 +
  5.6301 +        val specialTokens = neg :: quants @ ["$","(",")"] @ bTokens @ iTokens
  5.6302 +
  5.6303 +        fun vName bv s = NameSet.member s bv
  5.6304 +
  5.6305 +        fun checkVarName bv s = if vName bv s then s else "$" ^ s
  5.6306 +
  5.6307 +        fun varName bv = ppMap (checkVarName bv) ppString
  5.6308 +
  5.6309 +        fun checkFunctionName bv s =
  5.6310 +            if mem s specialTokens orelse vName bv s then "(" ^ s ^ ")" else s
  5.6311 +
  5.6312 +        fun functionName bv = ppMap (checkFunctionName bv) ppString
  5.6313 +
  5.6314 +        fun isI tm = Option.isSome (destI tm)
  5.6315 +
  5.6316 +        fun stripNeg (tm as Fn (f,[a])) =
  5.6317 +            if f <> neg then (0,tm)
  5.6318 +            else let val (n,tm) = stripNeg a in (n + 1, tm) end
  5.6319 +          | stripNeg tm = (0,tm)
  5.6320 +
  5.6321 +        val destQuant =
  5.6322 +            let
  5.6323 +              fun dest q (Fn (q', [Var v, body])) =
  5.6324 +                  if q <> q' then NONE
  5.6325 +                  else
  5.6326 +                    (case dest q body of
  5.6327 +                       NONE => SOME (q,v,[],body)
  5.6328 +                     | SOME (_,v',vs,body) => SOME (q, v, v' :: vs, body))
  5.6329 +                | dest _ _ = NONE
  5.6330 +            in
  5.6331 +              fn tm => Useful.first (fn q => dest q tm) quants
  5.6332 +            end
  5.6333 +
  5.6334 +        fun isQuant tm = Option.isSome (destQuant tm)
  5.6335 +
  5.6336 +        fun destBrack (Fn (b,[tm])) =
  5.6337 +            (case List.find (fn (n,_,_) => n = b) bracks of
  5.6338 +               NONE => NONE
  5.6339 +             | SOME (_,b1,b2) => SOME (b1,tm,b2))
  5.6340 +          | destBrack _ = NONE
  5.6341 +
  5.6342 +        fun isBrack tm = Option.isSome (destBrack tm)
  5.6343 +            
  5.6344 +        fun functionArgument bv ppstrm tm =
  5.6345 +            (addBreak ppstrm (1,0);
  5.6346 +             if isBrack tm then customBracket bv ppstrm tm
  5.6347 +             else if isVar tm orelse isConst tm then basic bv ppstrm tm
  5.6348 +             else bracket bv ppstrm tm)
  5.6349 +
  5.6350 +        and basic bv ppstrm (Var v) = varName bv ppstrm v
  5.6351 +          | basic bv ppstrm (Fn (f,args)) =
  5.6352 +            (beginBlock ppstrm Inconsistent 2;
  5.6353 +             functionName bv ppstrm f;
  5.6354 +             app (functionArgument bv ppstrm) args;
  5.6355 +             endBlock ppstrm)
  5.6356 +
  5.6357 +        and customBracket bv ppstrm tm =
  5.6358 +            case destBrack tm of
  5.6359 +              SOME (b1,tm,b2) => ppBracket b1 b2 (term bv) ppstrm tm
  5.6360 +            | NONE => basic bv ppstrm tm
  5.6361 +
  5.6362 +        and innerQuant bv ppstrm tm =
  5.6363 +            case destQuant tm of
  5.6364 +              NONE => term bv ppstrm tm
  5.6365 +            | SOME (q,v,vs,tm) =>
  5.6366 +              let
  5.6367 +                val bv = NameSet.addList (NameSet.add bv v) vs
  5.6368 +              in
  5.6369 +                addString ppstrm q;
  5.6370 +                varName bv ppstrm v;
  5.6371 +                app (fn v => (addBreak ppstrm (1,0); varName bv ppstrm v)) vs;
  5.6372 +                addString ppstrm ".";
  5.6373 +                addBreak ppstrm (1,0);
  5.6374 +                innerQuant bv ppstrm tm
  5.6375 +              end
  5.6376 +
  5.6377 +        and quantifier bv ppstrm tm =
  5.6378 +            if not (isQuant tm) then customBracket bv ppstrm tm
  5.6379 +            else
  5.6380 +              (beginBlock ppstrm Inconsistent 2;
  5.6381 +               innerQuant bv ppstrm tm;
  5.6382 +               endBlock ppstrm)
  5.6383 +
  5.6384 +        and molecule bv ppstrm (tm,r) =
  5.6385 +            let
  5.6386 +              val (n,tm) = stripNeg tm
  5.6387 +            in
  5.6388 +              beginBlock ppstrm Inconsistent n;
  5.6389 +              funpow n (fn () => addString ppstrm neg) ();
  5.6390 +              if isI tm orelse (r andalso isQuant tm) then bracket bv ppstrm tm
  5.6391 +              else quantifier bv ppstrm tm;
  5.6392 +              endBlock ppstrm
  5.6393 +            end
  5.6394 +
  5.6395 +        and term bv ppstrm tm = iPrinter (molecule bv) ppstrm (tm,false)
  5.6396 +
  5.6397 +        and bracket bv ppstrm tm = ppBracket "(" ")" (term bv) ppstrm tm
  5.6398 +  in
  5.6399 +    term NameSet.empty
  5.6400 +  end inputPpstrm inputTerm;
  5.6401 +end;
  5.6402 +
  5.6403 +fun toString tm = Parser.toString pp tm;
  5.6404 +
  5.6405 +(* Parsing *)
  5.6406 +
  5.6407 +local
  5.6408 +  open Parser;
  5.6409 +
  5.6410 +  infixr 9 >>++
  5.6411 +  infixr 8 ++
  5.6412 +  infixr 7 >>
  5.6413 +  infixr 6 ||
  5.6414 +
  5.6415 +  val isAlphaNum =
  5.6416 +      let
  5.6417 +        val alphaNumChars = explode "_'"
  5.6418 +      in
  5.6419 +        fn c => mem c alphaNumChars orelse Char.isAlphaNum c
  5.6420 +      end;
  5.6421 +
  5.6422 +  local
  5.6423 +    val alphaNumToken = atLeastOne (some isAlphaNum) >> implode;
  5.6424 +
  5.6425 +    val symbolToken =
  5.6426 +        let
  5.6427 +          fun isNeg c = str c = !negation
  5.6428 +                        
  5.6429 +          val symbolChars = explode "<>=-*+/\\?@|!$%&#^:;~"
  5.6430 +
  5.6431 +          fun isSymbol c = mem c symbolChars
  5.6432 +
  5.6433 +          fun isNonNegSymbol c = not (isNeg c) andalso isSymbol c
  5.6434 +        in
  5.6435 +          some isNeg >> str ||
  5.6436 +          (some isNonNegSymbol ++ many (some isSymbol)) >> (implode o op::)
  5.6437 +        end;
  5.6438 +
  5.6439 +    val punctToken =
  5.6440 +        let
  5.6441 +          val punctChars = explode "()[]{}.,"
  5.6442 +
  5.6443 +          fun isPunct c = mem c punctChars
  5.6444 +        in
  5.6445 +          some isPunct >> str
  5.6446 +        end;
  5.6447 +
  5.6448 +    val lexToken = alphaNumToken || symbolToken || punctToken;
  5.6449 +
  5.6450 +    val space = many (some Char.isSpace);
  5.6451 +  in
  5.6452 +    val lexer = (space ++ lexToken ++ space) >> (fn (_,(tok,_)) => tok);
  5.6453 +  end;
  5.6454 +
  5.6455 +  fun termParser inputStream =
  5.6456 +      let
  5.6457 +        val quants = !binders
  5.6458 +        and iOps = !infixes
  5.6459 +        and neg = !negation
  5.6460 +        and bracks = ("(",")") :: !brackets
  5.6461 +
  5.6462 +        val bracks = map (fn (b1,b2) => (b1 ^ b2, b1, b2)) bracks
  5.6463 +
  5.6464 +        val bTokens = map #2 bracks @ map #3 bracks
  5.6465 +
  5.6466 +        fun possibleVarName "" = false
  5.6467 +          | possibleVarName s = isAlphaNum (String.sub (s,0))
  5.6468 +
  5.6469 +        fun vName bv s = NameSet.member s bv
  5.6470 +
  5.6471 +        val iTokens = infixTokens iOps
  5.6472 +
  5.6473 +        val iParser = parseInfixes iOps (fn (f,a,b) => Fn (f,[a,b]))
  5.6474 +
  5.6475 +        val specialTokens = neg :: quants @ ["$"] @ bTokens @ iTokens
  5.6476 +
  5.6477 +        fun varName bv =
  5.6478 +            Parser.some (vName bv) ||
  5.6479 +            (exact "$" ++ some possibleVarName) >> (fn (_,s) => s)
  5.6480 +
  5.6481 +        fun fName bv s = not (mem s specialTokens) andalso not (vName bv s)
  5.6482 +
  5.6483 +        fun functionName bv =
  5.6484 +            Parser.some (fName bv) ||
  5.6485 +            (exact "(" ++ any ++ exact ")") >> (fn (_,(s,_)) => s)
  5.6486 +
  5.6487 +        fun basic bv tokens =
  5.6488 +            let
  5.6489 +              val var = varName bv >> Var
  5.6490 +
  5.6491 +              val const = functionName bv >> (fn f => Fn (f,[]))
  5.6492 +
  5.6493 +              fun bracket (ab,a,b) =
  5.6494 +                  (exact a ++ term bv ++ exact b) >>
  5.6495 +                  (fn (_,(tm,_)) => if ab = "()" then tm else Fn (ab,[tm]))
  5.6496 +
  5.6497 +              fun quantifier q =
  5.6498 +                  let
  5.6499 +                    fun bind (v,t) = Fn (q, [Var v, t])
  5.6500 +                  in
  5.6501 +                    (exact q ++ atLeastOne (some possibleVarName) ++
  5.6502 +                     exact ".") >>++
  5.6503 +                    (fn (_,(vs,_)) =>
  5.6504 +                        term (NameSet.addList bv vs) >>
  5.6505 +                        (fn body => foldr bind body vs))
  5.6506 +                  end
  5.6507 +            in
  5.6508 +              var ||
  5.6509 +              const ||
  5.6510 +              first (map bracket bracks) ||
  5.6511 +              first (map quantifier quants)
  5.6512 +            end tokens
  5.6513 +
  5.6514 +        and molecule bv tokens =
  5.6515 +            let
  5.6516 +              val negations = many (exact neg) >> length
  5.6517 +
  5.6518 +              val function =
  5.6519 +                  (functionName bv ++ many (basic bv)) >> Fn || basic bv
  5.6520 +            in
  5.6521 +              (negations ++ function) >>
  5.6522 +              (fn (n,tm) => funpow n (fn t => Fn (neg,[t])) tm)
  5.6523 +            end tokens
  5.6524 +
  5.6525 +        and term bv tokens = iParser (molecule bv) tokens
  5.6526 +      in
  5.6527 +        term NameSet.empty
  5.6528 +      end inputStream;
  5.6529 +in
  5.6530 +  fun fromString input =
  5.6531 +      let
  5.6532 +        val chars = Stream.fromList (explode input)
  5.6533 +
  5.6534 +        val tokens = everything (lexer >> singleton) chars
  5.6535 +
  5.6536 +        val terms = everything (termParser >> singleton) tokens
  5.6537 +      in
  5.6538 +        case Stream.toList terms of
  5.6539 +          [tm] => tm
  5.6540 +        | _ => raise Error "Syntax.stringToTerm"
  5.6541 +      end;
  5.6542 +end;
  5.6543 +
  5.6544 +local
  5.6545 +  val antiquotedTermToString =
  5.6546 +      Parser.toString (Parser.ppBracket "(" ")" pp);
  5.6547 +in
  5.6548 +  val parse = Parser.parseQuotation antiquotedTermToString fromString;
  5.6549 +end;
  5.6550 +
  5.6551 +end
  5.6552 +
  5.6553 +structure TermOrdered =
  5.6554 +struct type t = Term.term val compare = Term.compare end
  5.6555 +
  5.6556 +structure TermSet = ElementSet (TermOrdered);
  5.6557 +
  5.6558 +structure TermMap = KeyMap (TermOrdered);
  5.6559 +end;
  5.6560 +
  5.6561 +(**** Original file: Subst.sig ****)
  5.6562 +
  5.6563 +(* ========================================================================= *)
  5.6564 +(* FIRST ORDER LOGIC SUBSTITUTIONS                                           *)
  5.6565 +(* Copyright (c) 2002-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.6566 +(* ========================================================================= *)
  5.6567 +
  5.6568 +signature Subst =
  5.6569 +sig
  5.6570 +
  5.6571 +(* ------------------------------------------------------------------------- *)
  5.6572 +(* A type of first order logic substitutions.                                *)
  5.6573 +(* ------------------------------------------------------------------------- *)
  5.6574 +
  5.6575 +type subst
  5.6576 +
  5.6577 +(* ------------------------------------------------------------------------- *)
  5.6578 +(* Basic operations.                                                         *)
  5.6579 +(* ------------------------------------------------------------------------- *)
  5.6580 +
  5.6581 +val empty : subst
  5.6582 +
  5.6583 +val null : subst -> bool
  5.6584 +
  5.6585 +val size : subst -> int
  5.6586 +
  5.6587 +val peek : subst -> Metis.Term.var -> Metis.Term.term option
  5.6588 +
  5.6589 +val insert : subst -> Metis.Term.var * Metis.Term.term -> subst
  5.6590 +
  5.6591 +val singleton : Metis.Term.var * Metis.Term.term -> subst
  5.6592 +
  5.6593 +val union : subst -> subst -> subst
  5.6594 +
  5.6595 +val toList : subst -> (Metis.Term.var * Metis.Term.term) list
  5.6596 +
  5.6597 +val fromList : (Metis.Term.var * Metis.Term.term) list -> subst
  5.6598 +
  5.6599 +val foldl : (Metis.Term.var * Metis.Term.term * 'a -> 'a) -> 'a -> subst -> 'a
  5.6600 +
  5.6601 +val foldr : (Metis.Term.var * Metis.Term.term * 'a -> 'a) -> 'a -> subst -> 'a
  5.6602 +
  5.6603 +val pp : subst Metis.Parser.pp
  5.6604 +
  5.6605 +val toString : subst -> string
  5.6606 +
  5.6607 +(* ------------------------------------------------------------------------- *)
  5.6608 +(* Normalizing removes identity substitutions.                               *)
  5.6609 +(* ------------------------------------------------------------------------- *)
  5.6610 +
  5.6611 +val normalize : subst -> subst
  5.6612 +
  5.6613 +(* ------------------------------------------------------------------------- *)
  5.6614 +(* Applying a substitution to a first order logic term.                      *)
  5.6615 +(* ------------------------------------------------------------------------- *)
  5.6616 +
  5.6617 +val subst : subst -> Metis.Term.term -> Metis.Term.term
  5.6618 +
  5.6619 +(* ------------------------------------------------------------------------- *)
  5.6620 +(* Restricting a substitution to a smaller set of variables.                 *)
  5.6621 +(* ------------------------------------------------------------------------- *)
  5.6622 +
  5.6623 +val restrict : subst -> Metis.NameSet.set -> subst
  5.6624 +
  5.6625 +val remove : subst -> Metis.NameSet.set -> subst
  5.6626 +
  5.6627 +(* ------------------------------------------------------------------------- *)
  5.6628 +(* Composing two substitutions so that the following identity holds:         *)
  5.6629 +(*                                                                           *)
  5.6630 +(* subst (compose sub1 sub2) tm = subst sub2 (subst sub1 tm)                 *)
  5.6631 +(* ------------------------------------------------------------------------- *)
  5.6632 +
  5.6633 +val compose : subst -> subst -> subst
  5.6634 +
  5.6635 +(* ------------------------------------------------------------------------- *)
  5.6636 +(* Substitutions can be inverted iff they are renaming substitutions.        *) 
  5.6637 +(* ------------------------------------------------------------------------- *)
  5.6638 +
  5.6639 +val invert : subst -> subst  (* raises Error *)
  5.6640 +
  5.6641 +val isRenaming : subst -> bool
  5.6642 +
  5.6643 +(* ------------------------------------------------------------------------- *)
  5.6644 +(* Creating a substitution to freshen variables.                             *)
  5.6645 +(* ------------------------------------------------------------------------- *)
  5.6646 +
  5.6647 +val freshVars : Metis.NameSet.set -> subst
  5.6648 +
  5.6649 +(* ------------------------------------------------------------------------- *)
  5.6650 +(* Matching for first order logic terms.                                     *)
  5.6651 +(* ------------------------------------------------------------------------- *)
  5.6652 +
  5.6653 +val match : subst -> Metis.Term.term -> Metis.Term.term -> subst  (* raises Error *)
  5.6654 +
  5.6655 +(* ------------------------------------------------------------------------- *)
  5.6656 +(* Unification for first order logic terms.                                  *)
  5.6657 +(* ------------------------------------------------------------------------- *)
  5.6658 +
  5.6659 +val unify : subst -> Metis.Term.term -> Metis.Term.term -> subst  (* raises Error *)
  5.6660 +
  5.6661 +end
  5.6662 +
  5.6663 +(**** Original file: Subst.sml ****)
  5.6664 +
  5.6665 +structure Metis = struct open Metis
  5.6666 +(* Metis-specific ML environment *)
  5.6667 +nonfix ++ -- RL mem union subset;
  5.6668 +val explode = String.explode;
  5.6669 +val implode = String.implode;
  5.6670 +val print = TextIO.print;
  5.6671 +(* ========================================================================= *)
  5.6672 +(* FIRST ORDER LOGIC SUBSTITUTIONS                                           *)
  5.6673 +(* Copyright (c) 2002-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.6674 +(* ========================================================================= *)
  5.6675 +
  5.6676 +structure Subst :> Subst =
  5.6677 +struct
  5.6678 +
  5.6679 +open Useful;
  5.6680 +
  5.6681 +(* ------------------------------------------------------------------------- *)
  5.6682 +(* A type of first order logic substitutions.                                *)
  5.6683 +(* ------------------------------------------------------------------------- *)
  5.6684 +
  5.6685 +datatype subst = Subst of Term.term NameMap.map;
  5.6686 +
  5.6687 +(* ------------------------------------------------------------------------- *)
  5.6688 +(* Basic operations.                                                         *)
  5.6689 +(* ------------------------------------------------------------------------- *)
  5.6690 +
  5.6691 +val empty = Subst (NameMap.new ());
  5.6692 +
  5.6693 +fun null (Subst m) = NameMap.null m;
  5.6694 +
  5.6695 +fun size (Subst m) = NameMap.size m;
  5.6696 +
  5.6697 +fun peek (Subst m) v = NameMap.peek m v;
  5.6698 +
  5.6699 +fun insert (Subst m) v_tm = Subst (NameMap.insert m v_tm);
  5.6700 +
  5.6701 +fun singleton v_tm = insert empty v_tm;
  5.6702 +
  5.6703 +local
  5.6704 +  fun compatible (tm1,tm2) =
  5.6705 +      if tm1 = tm2 then SOME tm1 else raise Error "Subst.union: incompatible";
  5.6706 +in
  5.6707 +  fun union (s1 as Subst m1) (s2 as Subst m2) =
  5.6708 +      if NameMap.null m1 then s2
  5.6709 +      else if NameMap.null m2 then s1
  5.6710 +      else Subst (NameMap.union compatible m1 m2);
  5.6711 +end;
  5.6712 +
  5.6713 +fun toList (Subst m) = NameMap.toList m;
  5.6714 +
  5.6715 +fun fromList l = Subst (NameMap.fromList l);
  5.6716 +
  5.6717 +fun foldl f b (Subst m) = NameMap.foldl f b m;
  5.6718 +
  5.6719 +fun foldr f b (Subst m) = NameMap.foldr f b m;
  5.6720 +
  5.6721 +fun pp ppstrm sub =
  5.6722 +    Parser.ppBracket "<[" "]>"
  5.6723 +      (Parser.ppSequence "," (Parser.ppBinop " |->" Parser.ppString Term.pp))
  5.6724 +      ppstrm (toList sub);
  5.6725 +
  5.6726 +val toString = Parser.toString pp;
  5.6727 +
  5.6728 +(* ------------------------------------------------------------------------- *)
  5.6729 +(* Normalizing removes identity substitutions.                               *)
  5.6730 +(* ------------------------------------------------------------------------- *)
  5.6731 +
  5.6732 +local
  5.6733 +  fun isNotId (v,tm) = not (Term.equalVar v tm);
  5.6734 +in
  5.6735 +  fun normalize (sub as Subst m) =
  5.6736 +      let
  5.6737 +        val m' = NameMap.filter isNotId m
  5.6738 +      in
  5.6739 +        if NameMap.size m = NameMap.size m' then sub else Subst m'
  5.6740 +      end;
  5.6741 +end;
  5.6742 +
  5.6743 +(* ------------------------------------------------------------------------- *)
  5.6744 +(* Applying a substitution to a first order logic term.                      *)
  5.6745 +(* ------------------------------------------------------------------------- *)
  5.6746 +
  5.6747 +fun subst sub =
  5.6748 +    let
  5.6749 +      fun tmSub (tm as Term.Var v) =
  5.6750 +          (case peek sub v of
  5.6751 +             SOME tm' => if Sharing.pointerEqual (tm,tm') then tm else tm'
  5.6752 +           | NONE => tm)
  5.6753 +        | tmSub (tm as Term.Fn (f,args)) =
  5.6754 +          let
  5.6755 +            val args' = Sharing.map tmSub args
  5.6756 +          in
  5.6757 +            if Sharing.pointerEqual (args,args') then tm
  5.6758 +            else Term.Fn (f,args')
  5.6759 +          end
  5.6760 +    in
  5.6761 +      fn tm => if null sub then tm else tmSub tm
  5.6762 +    end;
  5.6763 +
  5.6764 +(* ------------------------------------------------------------------------- *)
  5.6765 +(* Restricting a substitution to a given set of variables.                   *)
  5.6766 +(* ------------------------------------------------------------------------- *)
  5.6767 +
  5.6768 +fun restrict (sub as Subst m) varSet =
  5.6769 +    let
  5.6770 +      fun isRestrictedVar (v,_) = NameSet.member v varSet
  5.6771 +
  5.6772 +      val m' = NameMap.filter isRestrictedVar m
  5.6773 +    in
  5.6774 +      if NameMap.size m = NameMap.size m' then sub else Subst m'
  5.6775 +    end;
  5.6776 +
  5.6777 +fun remove (sub as Subst m) varSet =
  5.6778 +    let
  5.6779 +      fun isRestrictedVar (v,_) = not (NameSet.member v varSet)
  5.6780 +
  5.6781 +      val m' = NameMap.filter isRestrictedVar m
  5.6782 +    in
  5.6783 +      if NameMap.size m = NameMap.size m' then sub else Subst m'
  5.6784 +    end;
  5.6785 +
  5.6786 +(* ------------------------------------------------------------------------- *)
  5.6787 +(* Composing two substitutions so that the following identity holds:         *)
  5.6788 +(*                                                                           *)
  5.6789 +(* subst (compose sub1 sub2) tm = subst sub2 (subst sub1 tm)                 *)
  5.6790 +(* ------------------------------------------------------------------------- *)
  5.6791 +
  5.6792 +fun compose (sub1 as Subst m1) sub2 =
  5.6793 +    let
  5.6794 +      fun f (v,tm,s) = insert s (v, subst sub2 tm)
  5.6795 +    in
  5.6796 +      if null sub2 then sub1 else NameMap.foldl f sub2 m1
  5.6797 +    end;
  5.6798 +
  5.6799 +(* ------------------------------------------------------------------------- *)
  5.6800 +(* Substitutions can be inverted iff they are renaming substitutions.        *) 
  5.6801 +(* ------------------------------------------------------------------------- *)
  5.6802 +
  5.6803 +local
  5.6804 +  fun inv (v, Term.Var w, s) =
  5.6805 +      if NameMap.inDomain w s then raise Error "Subst.invert: non-injective"
  5.6806 +      else NameMap.insert s (w, Term.Var v)
  5.6807 +    | inv (_, Term.Fn _, _) = raise Error "Subst.invert: non-variable";
  5.6808 +in
  5.6809 +  fun invert (Subst m) = Subst (NameMap.foldl inv (NameMap.new ()) m);
  5.6810 +end;
  5.6811 +
  5.6812 +val isRenaming = can invert;
  5.6813 +
  5.6814 +(* ------------------------------------------------------------------------- *)
  5.6815 +(* Creating a substitution to freshen variables.                             *)
  5.6816 +(* ------------------------------------------------------------------------- *)
  5.6817 +
  5.6818 +val freshVars =
  5.6819 +    let
  5.6820 +      fun add (v,m) = insert m (v, Term.newVar ())
  5.6821 +    in
  5.6822 +      NameSet.foldl add empty
  5.6823 +    end;
  5.6824 +
  5.6825 +(* ------------------------------------------------------------------------- *)
  5.6826 +(* Matching for first order logic terms.                                     *)
  5.6827 +(* ------------------------------------------------------------------------- *)
  5.6828 +
  5.6829 +local
  5.6830 +  fun matchList sub [] = sub
  5.6831 +    | matchList sub ((Term.Var v, tm) :: rest) =
  5.6832 +      let
  5.6833 +        val sub =
  5.6834 +            case peek sub v of
  5.6835 +              NONE => insert sub (v,tm)
  5.6836 +            | SOME tm' =>
  5.6837 +              if tm = tm' then sub
  5.6838 +              else raise Error "Subst.match: incompatible matches"
  5.6839 +      in
  5.6840 +        matchList sub rest
  5.6841 +      end
  5.6842 +    | matchList sub ((Term.Fn (f1,args1), Term.Fn (f2,args2)) :: rest) =
  5.6843 +      if f1 = f2 andalso length args1 = length args2 then
  5.6844 +        matchList sub (zip args1 args2 @ rest)
  5.6845 +      else raise Error "Subst.match: different structure"
  5.6846 +    | matchList _ _ = raise Error "Subst.match: functions can't match vars";
  5.6847 +in
  5.6848 +  fun match sub tm1 tm2 = matchList sub [(tm1,tm2)];
  5.6849 +end;
  5.6850 +
  5.6851 +(* ------------------------------------------------------------------------- *)
  5.6852 +(* Unification for first order logic terms.                                  *)
  5.6853 +(* ------------------------------------------------------------------------- *)
  5.6854 +
  5.6855 +local
  5.6856 +  fun solve sub [] = sub
  5.6857 +    | solve sub ((tm1_tm2 as (tm1,tm2)) :: rest) =
  5.6858 +      if Portable.pointerEqual tm1_tm2 then solve sub rest
  5.6859 +      else solve' sub (subst sub tm1) (subst sub tm2) rest
  5.6860 +
  5.6861 +  and solve' sub (Term.Var v) tm rest =
  5.6862 +      if Term.equalVar v tm then solve sub rest
  5.6863 +      else if Term.freeIn v tm then raise Error "Subst.unify: occurs check"
  5.6864 +      else
  5.6865 +        (case peek sub v of
  5.6866 +           NONE => solve (compose sub (singleton (v,tm))) rest
  5.6867 +         | SOME tm' => solve' sub tm' tm rest)
  5.6868 +    | solve' sub tm1 (tm2 as Term.Var _) rest = solve' sub tm2 tm1 rest
  5.6869 +    | solve' sub (Term.Fn (f1,args1)) (Term.Fn (f2,args2)) rest =
  5.6870 +      if f1 = f2 andalso length args1 = length args2 then
  5.6871 +        solve sub (zip args1 args2 @ rest)
  5.6872 +      else
  5.6873 +        raise Error "Subst.unify: different structure";
  5.6874 +in
  5.6875 +  fun unify sub tm1 tm2 = solve sub [(tm1,tm2)];
  5.6876 +end;
  5.6877 +
  5.6878 +end
  5.6879 +end;
  5.6880 +
  5.6881 +(**** Original file: Atom.sig ****)
  5.6882 +
  5.6883 +(* ========================================================================= *)
  5.6884 +(* FIRST ORDER LOGIC ATOMS                                                   *)
  5.6885 +(* Copyright (c) 2001-2006 Joe Hurd, distributed under the GNU GPL version 2 *)
  5.6886 +(* ========================================================================= *)
  5.6887 +
  5.6888 +signature Atom =
  5.6889 +sig
  5.6890 +
  5.6891 +(* ------------------------------------------------------------------------- *)
  5.6892 +(* A type for storing first order logic atoms.                               *)
  5.6893 +(* ------------------------------------------------------------------------- *)
  5.6894 +
  5.6895 +type relationName = Metis.Name.name
  5.6896 +
  5.6897 +type relation = relationName * int
  5.6898 +
  5.6899 +type atom = relationName * Metis.Term.term list
  5.6900 +
  5.6901 +(* ------------------------------------------------------------------------- *)
  5.6902 +(* Constructors and destructors.                                             *)
  5.6903 +(* ------------------------------------------------------------------------- *)
  5.6904 +
  5.6905 +val name : atom -> relationName
  5.6906 +
  5.6907 +val arguments : atom -> Metis.Term.term list
  5.6908 +
  5.6909 +val arity : atom -> int
  5.6910 +
  5.6911 +val relation : atom -> relation
  5.6912 +
  5.6913 +val functions : atom -> Metis.NameAritySet.set
  5.6914 +
  5.6915 +val functionNames : atom -> Metis.NameSet.set
  5.6916 +
  5.6917 +(* Binary relations *)
  5.6918 +
  5.6919 +val mkBinop : relationName -> Metis.Term.term * Metis.Term.term -> atom
  5.6920 +
  5.6921 +val destBinop : relationName -> atom -> Metis.Term.term * Metis.Term.term
  5.6922 +
  5.6923 +val isBinop : relationName -> atom -> bool
  5.6924 +
  5.6925 +(* ------------------------------------------------------------------------- *)
  5.6926 +(* The size of an atom in symbols.                                           *)
  5.6927 +(* ------------------------------------------------------------------------- *)
  5.6928 +
  5.6929 +val symbols : atom -> int
  5.6930 +
  5.6931 +(* ------------------------------------------------------------------------- *)
  5.6932 +(* A total comparison function for atoms.                                    *)
  5.6933 +(* ------------------------------------------------------------------------- *)
  5.6934 +
  5.6935 +val compare : atom * atom -> order
  5.6936 +
  5.6937 +(* ------------------------------------------------------------------------- *)
  5.6938 +(* Subterms.                                                                 *)
  5.6939 +(* ------------------------------------------------------------------------- *)
  5.6940 +
  5.6941 +val subterm : atom -> Metis.Term.path -> Metis.Term.term
  5.6942 +
  5.6943 +val subterms : atom -> (Metis.Term.path * Metis.Term.term) list
  5.6944 +
  5.6945 +val replace : atom -> Metis.Term.path * Metis.Term.term -> atom
  5.6946 +
  5.6947 +val find : (Metis.Term.term -> bool) -> atom -> Metis.Term.path option
  5.6948 +
  5.6949 +(* ------------------------------------------------------------------------- *)
  5.6950 +(* Free variables.                                                           *)
  5.6951 +(* ------------------------------------------------------------------------- *)
  5.6952 +
  5.6953 +val freeIn : Metis.Term.var -> atom -> bool
  5.6954 +
  5.6955 +val freeVars : atom -> Metis.NameSet.set
  5.6956 +
  5.6957 +(* ------------------------------------------------------------------------- *)
  5.6958 +(* Substitutions.                                                            *)
  5.6959 +(* ------------------------------------------------------------------------- *)
  5.6960 +
  5.6961 +val subst : Metis.Subst.subst -> atom -> atom
  5.6962 +
  5.6963 +(* ------------------------------------------------------------------------- *)
  5.6964 +(* Matching.                                                                 *)
  5.6965 +(* ------------------------------------------------------------------------- *)
  5.6966 +
  5.6967 +val match : Metis.Subst.subst -> atom -> atom -> Metis.Subst.subst  (* raises Error *)
  5.6968 +
  5.6969 +(* ------------------------------------------------------------------------- *)
  5.6970 +(* Unification.                                                              *)
  5.6971 +(* ------------------------------------------------------------------------- *)
  5.6972 +
  5.6973 +val unify : Metis.Subst.subst -> atom -> atom -> Metis.Subst.subst  (* raises Error *)
  5.6974 +
  5.6975 +(* ------------------------------------------------------------------------- *)
  5.6976 +(* The equality relation.                                                    *)
  5.6977 +(* ------------------------------------------------------------------------- *)
  5.6978 +
  5.6979 +val eqRelation : relation