HOL theorem-proving system

Revision: 8747
          http://hol.svn.sourceforge.net/hol/?rev=8747&view=rev
Author:   webertj
Date:     2010-11-11 14:02:32 +0000 (Thu, 11 Nov 2010)

Log Message:
-----------
HolQbfLib now supports Squolem2.

Modified Paths:
--------------
    HOL/Manual/Description/HolQbf.tex
    HOL/doc/kananaskis-7.release.html
    HOL/src/HolQbf/HolQbfLib.sml
    HOL/src/HolQbf/QbfCertificate.sml

Modified: HOL/Manual/Description/HolQbf.tex
===================================================================
--- HOL/Manual/Description/HolQbf.tex	2010-11-11 07:54:37 UTC (rev 8746)
+++ HOL/Manual/Description/HolQbf.tex	2010-11-11 14:02:32 UTC (rev 8747)
@@ -13,19 +13,22 @@
 (Section~\ref{sec:HolSatLib}), and has been described in parts in the
 following publication:
 \begin{itemize}
-\item Tjark Weber: {\it Validating QBF Invalidity in HOL4}.  Published
-  at the International Conference on Interactive Theorem Proving (ITP)
-  2010.
+\item Tjark Weber: {\it Validating QBF Invalidity in HOL4}.  In Matt
+  Kaufmann and Lawrence C.\ Paulson, editors, Interactive Theorem
+  Proving, First International Conference, ITP 2010, Edinburgh, UK,
+  July 11--14, 2010.  Proceedings, volume 6172 of Lecture Notes in
+  Computer Science, pages 466--480.  Springer, 2010.
 \end{itemize}
 \ml{HolQbfLib} uses an external QBF solver, Squolem, to disprove
 invalid Quantified Boolean Formulae.
 
 \subsection{Installing Squolem}
 
-\ml{HolQbfLib} has been tested with Squolem 1.03 (release date
-2007-01-28).  Squolem can be obtained for Windows and Linux from
+\ml{HolQbfLib} has been tested with (the x86 Linux version of) Squolem
+2.02 (release date 2010-11-10).  Later versions might work as well.
+Squolem can be obtained from
 \url{http://www.cprover.org/qbv/download.html}.  After installation,
-you must make the executable available as {\tt squolem}, \eg, by
+you must make the executable available as {\tt squolem2}, \eg, by
 placing it into a folder that is in your {\tt \$PATH}.  This name is
 currently hard-coded: there is no configuration option to tell \HOL{}
 about the location and name of the Squolem executable.
@@ -74,12 +77,12 @@
 
 - disprove ``?x. x /\ ~x``;
 <<HOL message: HolQbfLib: calling external command
-  'squolem --save-certificate /tmp/file0Pw2Tg >& /dev/null'>>
+  'squolem2 -c /tmp/file0Pw2Tg >& /dev/null'>>
 > val it =  [?x. x /\ ~x] |- F : thm
 
 - disprove ``!x. ?y. x /\ y``;
 <<HOL message: HolQbfLib: calling external command
-  'squolem --save-certificate /tmp/fileZAGj4m >& /dev/null'>>
+  'squolem2 -c /tmp/fileZAGj4m >& /dev/null'>>
 > val it =
      [!x. ?y. x /\ y] |- F : thm
 \end{verbatim}

Modified: HOL/doc/kananaskis-7.release.html
===================================================================
--- HOL/doc/kananaskis-7.release.html	2010-11-11 07:54:37 UTC (rev 8746)
+++ HOL/doc/kananaskis-7.release.html	2010-11-11 14:02:32 UTC (rev 8747)
@@ -37,6 +37,9 @@
 width of the resulting word when applied to a numeral and a
 fixed-width word. Minor incompatibility.</p></li>
 
+<li><p><code>HolQbfLib</code> now supports Squolem2. (Support for
+Squolem 1.x has been discontinued. Incompatibility.)</p></li>
+
 </ul>
 
 <h2 id="bugs-fixed">Bugs fixed:</h2>

Modified: HOL/src/HolQbf/HolQbfLib.sml
===================================================================
--- HOL/src/HolQbf/HolQbfLib.sml	2010-11-11 07:54:37 UTC (rev 8746)
+++ HOL/src/HolQbf/HolQbfLib.sml	2010-11-11 14:02:32 UTC (rev 8747)
@@ -12,7 +12,7 @@
     val path = FileSys.tmpName ()
     val _ = QDimacs.write_qdimacs_file path t
     (* the actual system call to Squolem *)
-    val cmd = "squolem --save-certificate " ^ path ^ " >& /dev/null"
+    val cmd = "squolem2 -c " ^ path ^ " >& /dev/null"
     val _ = if !QbfTrace.trace > 1 then
         Feedback.HOL_MESG ("HolQbfLib: calling external command '" ^ cmd ^ "'")
       else ()

Modified: HOL/src/HolQbf/QbfCertificate.sml
===================================================================
--- HOL/src/HolQbf/QbfCertificate.sml	2010-11-11 07:54:37 UTC (rev 8746)
+++ HOL/src/HolQbf/QbfCertificate.sml	2010-11-11 14:02:32 UTC (rev 8747)
@@ -92,13 +92,13 @@
       raise ERR "read_certificate_file"
         "resolution: '0' expected to terminate list of resolution clauses"
     (* literal list -> string list -> resolution *)
-    fun resolution_args lits ("0" :: xs) =
+    fun resolution_args lits ("*" :: xs) =
       (List.rev lits, resolution_clauses [] xs)
       | resolution_args lits (lit :: xs) =
       resolution_args (int_from_string lit :: lits) xs
       | resolution_args _ [] =
       raise ERR "read_certificate_file"
-        "resolution: '0' expected to terminate list of resolution literals"
+        "resolution: '*' expected to terminate list of resolution literals"
     (* (cindex, resolution) dict -> string list -> (cindex, resolution) dict *)
     fun resolution res (cindex :: xs) =
       Redblackmap.insert (res, int_from_string cindex, resolution_args [] xs)
@@ -144,7 +144,7 @@
       | certificate (ext, res) (xs :: xss) =
       certificate (ext, resolution res xs) xss
       | certificate _ [] =
-        raise ERR "read_certificate_file" "empty certificate"
+        raise ERR "read_certificate_file" "missing conclusion"
   in
     (certificate
        (Redblackmap.mkDict Int.compare, Redblackmap.mkDict Int.compare)


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 8797
          http://hol.svn.sourceforge.net/hol/?rev=8797&view=rev
Author:   michaeln
Date:     2010-12-15 04:46:20 +0000 (Wed, 15 Dec 2010)

Log Message:
-----------
Move name-of-kernel string variable (kernelid) from HolKernel to Theory.

Modified Paths:
--------------
    HOL/src/0/HolKernel.sml
    HOL/src/0/Theory.sml
    HOL/src/experimental-kernel/HolKernel.sml
    HOL/src/experimental-kernel/Theory.sml
    HOL/src/prekernel/FinalTheory-sig.sml
    HOL/std.prelude
    HOL/tools-poly/prelude.ML

Modified: HOL/src/0/HolKernel.sml
===================================================================
--- HOL/src/0/HolKernel.sml	2010-12-15 04:45:35 UTC (rev 8796)
+++ HOL/src/0/HolKernel.sml	2010-12-15 04:46:20 UTC (rev 8797)
@@ -16,8 +16,6 @@
           General term operations
  ---------------------------------------------------------------------------*)
 
-val kernelid = "stdknl"
-
 fun dest_monop c e M =
  let val (c1,N) = with_exn dest_comb M e
  in if same_const c c1 then N else raise e end
@@ -42,9 +40,9 @@
 (* Take a binder apart. Fails on paired binders.                             *)
 (*---------------------------------------------------------------------------*)
 
-local 
-  fun dest M = 
-    let val (c,Rand) = dest_comb M 
+local
+  fun dest M =
+    let val (c,Rand) = dest_comb M
     in (c,dest_abs Rand) end
 in
 fun dest_binder c e M =

Modified: HOL/src/0/Theory.sml
===================================================================
--- HOL/src/0/Theory.sml	2010-12-15 04:45:35 UTC (rev 8796)
+++ HOL/src/0/Theory.sml	2010-12-15 04:46:20 UTC (rev 8797)
@@ -62,6 +62,8 @@
 val ERR  = mk_HOL_ERR "Theory";
 val WARN = HOL_WARNING "Theory";
 
+val kernelid = "stdknl"
+
 type thy_addon = {sig_ps    : (ppstream -> unit) option,
                   struct_ps : (ppstream -> unit) option}
 

Modified: HOL/src/experimental-kernel/HolKernel.sml
===================================================================
--- HOL/src/experimental-kernel/HolKernel.sml	2010-12-15 04:45:35 UTC (rev 8796)
+++ HOL/src/experimental-kernel/HolKernel.sml	2010-12-15 04:46:20 UTC (rev 8797)
@@ -12,8 +12,6 @@
 
 val ERR = mk_HOL_ERR "HolKernel";
 
-val kernelid = "expknl"
-
 (*---------------------------------------------------------------------------
           General term operations
  ---------------------------------------------------------------------------*)

Modified: HOL/src/experimental-kernel/Theory.sml
===================================================================
--- HOL/src/experimental-kernel/Theory.sml	2010-12-15 04:45:35 UTC (rev 8796)
+++ HOL/src/experimental-kernel/Theory.sml	2010-12-15 04:46:20 UTC (rev 8797)
@@ -60,6 +60,7 @@
 
 val ERR  = mk_HOL_ERR "Theory";
 val WARN = HOL_WARNING "Theory";
+val kernelid = "expknl"
 
 type thy_addon = {sig_ps    : (ppstream -> unit) option,
                   struct_ps : (ppstream -> unit) option}

Modified: HOL/src/prekernel/FinalTheory-sig.sml
===================================================================
--- HOL/src/prekernel/FinalTheory-sig.sml	2010-12-15 04:45:35 UTC (rev 8796)
+++ HOL/src/prekernel/FinalTheory-sig.sml	2010-12-15 04:46:20 UTC (rev 8797)
@@ -9,6 +9,8 @@
                     struct_ps : (ppstream -> unit) option}
   type num = Arbnum.num
 
+  val kernelid : string
+
 (* Create a new theory *)
 
   val new_theory         : string -> unit

Modified: HOL/std.prelude
===================================================================
--- HOL/std.prelude	2010-12-15 04:45:35 UTC (rev 8796)
+++ HOL/std.prelude	2010-12-15 04:46:20 UTC (rev 8797)
@@ -149,7 +149,7 @@
    "\n---------------------------------------------------------------------\n"
   ^"       HOL-4 ["
   ^Globals.release^" "^Lib.int_to_string(Globals.version)
-  ^" ("^kernelid^", "^build_stamp
+  ^" ("^Theory.kernelid^", "^build_stamp
   ^")]\n\n       For introductory HOL help, type: help \"hol\";\n"
   ^"\n---------------------------------------------------------------------\n\
    \\n");

Modified: HOL/tools-poly/prelude.ML
===================================================================
--- HOL/tools-poly/prelude.ML	2010-12-15 04:45:35 UTC (rev 8796)
+++ HOL/tools-poly/prelude.ML	2010-12-15 04:46:20 UTC (rev 8797)
@@ -132,7 +132,7 @@
    "\n---------------------------------------------------------------------\n"
   ^"       HOL-4 ["
   ^Globals.release^" "^Lib.int_to_string(Globals.version)
-  ^" ("^kernelid^", "^build_stamp^")"
+  ^" ("^Theory.kernelid^", "^build_stamp^")"
   ^"]\n\n       For introductory HOL help, type: help \"hol\";"
   ^"\n---------------------------------------------------------------------\n\
    \\n")


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 8799
          http://hol.svn.sourceforge.net/hol/?rev=8799&view=rev
Author:   michaeln
Date:     2010-12-15 04:47:29 +0000 (Wed, 15 Dec 2010)

Log Message:
-----------
Make new 'postkernel' directory to allow sharing of HolKernel module.

Intention is to move more code into this directory if it's possible to get
more sharing across the kernels.

Modified Paths:
--------------
    HOL/src/0/Holmakefile
    HOL/tools/build-sequence

Added Paths:
-----------
    HOL/src/postkernel/
    HOL/src/postkernel/HolKernel.sml

Removed Paths:
-------------
    HOL/src/0/HolKernel.sml
    HOL/src/experimental-kernel/HolKernel.sml

Deleted: HOL/src/0/HolKernel.sml
===================================================================
--- HOL/src/0/HolKernel.sml	2010-12-15 04:46:47 UTC (rev 8798)
+++ HOL/src/0/HolKernel.sml	2010-12-15 04:47:29 UTC (rev 8799)
@@ -1,588 +0,0 @@
-structure HolKernel =
-struct
-
-  open Feedback Globals Lib Type Term Thm Theory Definition
-
-
-(*---------------------------------------------------------------------------
-     Miscellaneous other stuff that builds on top of kernel facilities.
- ---------------------------------------------------------------------------*)
-
-infixr -->;  infix |->;
-
-val ERR = mk_HOL_ERR "HolKernel";
-
-(*---------------------------------------------------------------------------
-          General term operations
- ---------------------------------------------------------------------------*)
-
-fun dest_monop c e M =
- let val (c1,N) = with_exn dest_comb M e
- in if same_const c c1 then N else raise e end
-
-local fun dest tm =
-       let val (Rator,N) = dest_comb tm
-           val (c,M) = dest_comb Rator
-       in (c,(M,N)) end
-in
-fun dest_binop c e tm =
-   let val (c1,pair) = with_exn dest tm e
-   in if same_const c c1 then pair else raise e end
-end
-
-fun dest_triop p e M =
-  let val (f,z) = with_exn dest_comb M e
-      val (x,y) = dest_binop p e f
-  in (x,y,z)
-  end;
-
-(*---------------------------------------------------------------------------*)
-(* Take a binder apart. Fails on paired binders.                             *)
-(*---------------------------------------------------------------------------*)
-
-local
-  fun dest M =
-    let val (c,Rand) = dest_comb M
-    in (c,dest_abs Rand) end
-in
-fun dest_binder c e M =
-  let val (c1,p) = with_exn dest M e
-  in if same_const c c1 then p else raise e end
-end
-
-
-local fun dest M =
-       let val (Rator,Rand) = dest_comb M in (dest_thy_const Rator,Rand) end
-in
-fun sdest_monop (name,thy) e M =
- let val ({Name,Thy,...},Rand) = with_exn dest M e
- in if Name=name andalso Thy=thy then Rand else raise e
- end;
-end
-
-local fun dest tm =
-       let val (Rator,N) = dest_comb tm
-           val (c,M) = dest_comb Rator
-       in (dest_thy_const c,(M,N))
-       end
-in
-fun sdest_binop (name,thy) e tm =
-   let val ({Name,Thy,...},pair) = with_exn dest tm e
-   in if Name=name andalso Thy=thy then pair else raise e
-   end
-end;
-
-local fun dest M =
-       let val (c, Rand) = dest_comb M
-       in (dest_thy_const c,dest_abs Rand)
-       end
-in
-fun sdest_binder (name,thy) e M =
-  let val ({Name,Thy,...}, p) = with_exn dest M e
-  in if Name=name andalso Thy=thy then p else raise e
-  end
-end;
-
-fun single x = [x];
-
-(* Breaks term down until binop no longer occurs at top level in result list *)
-
-fun strip_binop dest =
- let fun strip A [] = rev A
-       | strip A (h::t) =
-          case dest h
-           of NONE => strip (h::A) t
-            | SOME(c1,c2) => strip A (c1::c2::t)
- in strip [] o single
- end;
-
-(* For right-associative binary operators. Tail recursive. *)
-
-fun spine_binop dest =
- let fun strip A tm =
-       case dest tm
-         of NONE => rev (tm::A)
-          | SOME (l,r) => strip (l::A) r
- in strip []
- end;
-
-(* for left-associative binary operators.  Tail recursive *)
-fun lspine_binop dest = let
-  fun strip A tm =
-      case dest tm of
-        NONE => tm :: A
-      | SOME (l,r) => strip (r::A) l
-in
-  strip []
-end;
-
-(* For right-associative binary operators. Tail recursive. *)
-
-fun list_mk_rbinop mk_binop alist =
-    case List.rev alist of
-      [] => raise ERR "list_mk_rbinop" "empty list"
-    | h::t => rev_itlist mk_binop t h
-
-(* For left-associative binary operators. Tail recursive. *)
-
-fun list_mk_lbinop _ [] = raise ERR "list_mk_lbinop" "empty list"
-  | list_mk_lbinop mk_binop (h::t) = rev_itlist (C mk_binop) t h;
-
-fun mk_binder c f (p as (Bvar,_)) =
-   mk_comb(inst[alpha |-> type_of Bvar] c, mk_abs p)
-   handle HOL_ERR {message,...} => raise ERR f message;
-
-fun list_mk_fun (dtys, rty) = List.foldr op--> rty dtys
-
-val strip_fun =
-  let val dest = total dom_rng
-      fun strip acc ty =
-          case dest ty
-            of SOME (d,r) => strip (d::acc) r
-             | NONE => (rev acc, ty)
-  in strip []
-  end;
-
-
-val strip_comb =
- let val destc = total dest_comb
-     fun strip rands M =
-      case destc M
-       of NONE => (M, rands)
-        | SOME(Rator,Rand) => strip (Rand::rands) Rator
- in strip []
- end;
-
-
-datatype lambda
-   = VAR   of string * hol_type
-   | CONST of {Name:string, Thy:string, Ty:hol_type}
-   | COMB  of term * term
-   | LAMB  of term * term;
-
-fun dest_term M =
-  COMB(dest_comb M) handle HOL_ERR _ =>
-  LAMB(dest_abs M)  handle HOL_ERR _ =>
-  VAR (dest_var M)  handle HOL_ERR _ =>
-  CONST(dest_thy_const M);
-
-(*---------------------------------------------------------------------------*
- * Used to implement natural deduction style discharging of hypotheses. All  *
- * hypotheses alpha-convertible to the dischargee are removed.               *
- *---------------------------------------------------------------------------*)
-
-fun disch(w,wl) = List.filter (not o Term.aconv w) wl;
-
-
-(*---------------------------------------------------------------------------*
- * Search a term for a sub-term satisfying the predicate P. If application   *
- * of P raises an exception, that propagates to the caller. Therefore,       *
- * P should be a total predicate: otherwise, the caller won't know whether   *
- * the search failed because the sought-for subterm is not there, or because *
- * P failed.                                                                 *
- *---------------------------------------------------------------------------*)
-
-fun find_term P =
- let fun find_tm tm =
-      if P tm then tm else
-      if is_abs tm then find_tm (body tm) else
-      if is_comb tm
-         then let val (Rator,Rand) = dest_comb tm
-              in find_tm Rator handle HOL_ERR _ => find_tm Rand
-              end
-         else raise ERR "find_term" ""
- in find_tm
- end;
-
-(*---------------------------------------------------------------------------
- * find_terms: (term -> bool) -> term -> term list
- *
- *  Find all subterms in a term that satisfy a given predicate p.
- *
- * Added TFM 88.03.31
- *---------------------------------------------------------------------------*)
-
-fun find_terms P =
- let fun accum tl tm =
-      let val tl' = if P tm then tm::tl else tl
-      in accum tl' (body tm)
-         handle HOL_ERR _ =>
-          if is_comb tm
-          then let val (r1,r2) = dest_comb tm
-               in accum (accum tl' r1) r2
-               end
-          else tl'
-      end
- in accum []
- end;
-
-(* ----------------------------------------------------------------------
-    find_maximal_terms[l]
-
-    finds sub-terms within a term, but doesn't look into sub-terms that
-    match the provided predicate.  The find_maximal_termsl version
-    returns the terms as a list rather than a set.
-   ---------------------------------------------------------------------- *)
-
-fun find_maximal_terms P t = let
-  fun recurse acc tlist =
-      case tlist of
-        [] => acc
-      | t::ts =>
-        if P t then recurse (HOLset.add(acc, t)) ts
-        else
-          case dest_term t of
-            COMB(f,x) => recurse acc (f::x::ts)
-          | LAMB(v,b) => recurse acc (b::ts)
-          | _ => recurse acc ts
-in
-  recurse empty_tmset [t]
-end
-
-fun find_maximal_termsl P t = HOLset.listItems (find_maximal_terms P t)
-
-(* ----------------------------------------------------------------------
-    term_size
-
-    Returns a term's size.  There's no logical significance to this
-    number, but it can be useful.
-   ---------------------------------------------------------------------- *)
-
-fun term_size t = let
-  fun recurse acc tlist =
-      case tlist of
-        [] => acc
-      | t::ts =>
-        case dest_term t of
-          COMB(f, x) => recurse acc (f::x::ts)
-        | LAMB(v,b) => recurse (1 + acc) (b::ts)
-        | _ => recurse (1 + acc) ts
-in
-  recurse 0 [t]
-end
-
-(*---------------------------------------------------------------------------
- * Subst_occs
- * Put a new variable in tm2 at designated (and free) occurrences of redex.
- * Rebuilds the entire term.
- *---------------------------------------------------------------------------*)
-
-local
-fun splice ({redex,...}:{redex:term,residue:term}) v occs tm2 =
-   let fun graft (r as {occs=[], ...}) = r
-         | graft {tm, occs, count} =
-          if term_eq redex tm
-          then if (List.hd occs=count+1)
-               then {tm=v, occs=List.tl occs, count=count+1}
-               else {tm=tm, occs=occs, count=count+1}
-          else if (is_comb tm)
-               then let val (Rator, Rand) = dest_comb tm
-                        val {tm=Rator', occs=occs', count=count'} =
-                                        graft {tm=Rator,occs=occs,count=count}
-                        val {tm=Rand', occs=occs'', count=count''} =
-                                        graft {tm=Rand,occs=occs',count=count'}
-                    in {tm=mk_comb(Rator', Rand'),
-                        occs=occs'', count=count''}
-                    end
-               else if is_abs tm
-                    then let val (Bvar,Body) = dest_abs tm
-                             val {tm, count, occs} =
-                                        graft{tm=Body,count=count,occs=occs}
-                         in {tm=mk_abs(Bvar, tm),
-                             count=count, occs=occs}
-                         end
-                    else {tm=tm, occs=occs, count=count}
-   in #tm(graft {tm=tm2, occs=occs, count=0})
-   end
-
-fun rev_itlist3 f L1 L2 L3 base_value =
- let fun rev_it3 (a::rst1) (b::rst2) (c::rst3) base =
-             rev_it3 rst1 rst2 rst3 (f a b c base)
-       | rev_it3 [] [] [] base = base
-       | rev_it3 _ _ _ _ = raise ERR "rev_itlist3"
-                                  "not all lists have same size"
- in rev_it3 L1 L2 L3 base_value
- end
-
-val sort = Lib.sort (Lib.curry (op <=) : int -> int -> bool)
-in
-fun subst_occs occ_lists tm_subst tm =
-   let val occ_lists' = map sort occ_lists
-       val (new_vars,theta) =
-               Lib.itlist (fn {redex,residue} => fn (V,T) =>
-                         let val v = genvar(type_of redex)
-                         in (v::V,  (v |-> residue)::T)  end)
-                      tm_subst ([],[])
-       val template = rev_itlist3 splice tm_subst new_vars occ_lists' tm
-   in subst theta template
-   end
-end;
-
-
-(*---------------------------------------------------------------------------
-       Higher order matching (from jrh via Michael Norrish - June 2001)
- ---------------------------------------------------------------------------*)
-
-local
-  exception NOT_FOUND
-  fun find_residue red [] = raise NOT_FOUND
-    | find_residue red ({redex,residue}::rest) = if red = redex then residue
-                                                 else find_residue red rest
-  fun in_dom x [] = false
-    | in_dom x ({redex,residue}::rest) = (x = redex) orelse in_dom x rest
-  fun safe_insert (n as {redex,residue}) l = let
-    val z = find_residue redex l
-  in
-    if residue = z then l
-    else failwith "match: safe_insert"
-  end handle NOT_FOUND => n::l  (* binding not there *)
-  fun safe_inserta (n as {redex,residue}) l = let
-    val z = find_residue redex l
-  in
-    if aconv residue z then l
-    else failwith "match: safe_inserta"
-  end handle NOT_FOUND => n::l
-  val mk_dummy = let
-    val name = fst(dest_var(genvar Type.alpha))
-  in fn ty => mk_var(name, ty)
-  end
-
-
-  fun term_pmatch lconsts env vtm ctm (sofar as (insts,homs)) =
-    if is_var vtm then let
-        val ctm' = find_residue vtm env
-      in
-        if ctm' = ctm then sofar else failwith "term_pmatch"
-      end handle NOT_FOUND =>
-                 if HOLset.member(lconsts, vtm) then
-                   if ctm = vtm then sofar
-                   else
-                     failwith "term_pmatch: can't instantiate local constant"
-                 else (safe_inserta (vtm |-> ctm) insts, homs)
-    else if is_const vtm then let
-        val {Thy = vthy, Name = vname, Ty = vty} = dest_thy_const vtm
-        val {Thy = cthy, Name = cname, Ty = cty} = dest_thy_const ctm
-      in
-        if vname = cname andalso vthy = cthy then
-          if cty = vty then sofar
-          else (safe_insert (mk_dummy vty |-> mk_dummy cty) insts, homs)
-        else failwith "term_pmatch"
-      end
-    else if is_abs vtm then let
-        val (vv,vbod) = dest_abs vtm
-        val (cv,cbod) = dest_abs ctm
-        val (_, vty) = dest_var vv
-        val (_, cty) = dest_var cv
-        val sofar' = (safe_insert(mk_dummy vty |-> mk_dummy cty) insts, homs)
-      in
-        term_pmatch lconsts ((vv |-> cv)::env) vbod cbod sofar'
-      end
-    else let
-        val vhop = repeat rator vtm
-      in
-        if is_var vhop andalso not (HOLset.member(lconsts, vhop)) andalso
-           not (in_dom vhop env)
-        then let
-            val vty = type_of vtm
-            val cty = type_of ctm
-            val insts' = if vty = cty then insts
-                         else safe_insert (mk_dummy vty |-> mk_dummy cty) insts
-          in
-            (insts', (env,ctm,vtm)::homs)
-          end
-        else let
-            val (lv,rv) = dest_comb vtm
-            val (lc,rc) = dest_comb ctm
-            val sofar' = term_pmatch lconsts env lv lc sofar
-          in
-            term_pmatch lconsts env rv rc sofar'
-          end
-      end
-
-(*
-fun get_type_insts avoids L =
- let val avtys = itlist (fn ty => fn (p,o) => (ty-->p, ty-->o))
-                        avoids (bool,bool)
-     val (pat,ob) = itlist (fn {redex,residue} => fn (pat,ob) =>
-                               (type_of redex-->pat, type_of residue-->ob))
-                         L avtys
-
- in match_type pat ob
- end
-
-fun get_type_insts avoids L =
- let val tytheta = itlist (fn {redex,residue} =>
-          match_type_in_context (snd(dest_var redex)) (type_of residue))
-                     L []
- in if null(intersect avoids (map #residue tytheta))
-    then tytheta
-    else raise ERR "get_type_insts" "attempt to bind fixed type variable"
- end
-*)
-fun get_type_insts avoids L (tyS,Id) =
- itlist (fn {redex,residue} => fn Theta =>
-          raw_match_type (snd(dest_var redex)) (type_of residue) Theta)
-       L (tyS,union avoids Id)
-
-fun separate_insts tyavoids insts = let
-  val (realinsts, patterns) = partition (is_var o #redex) insts
-  val betacounts =
-      if patterns = [] then []
-      else
-        itlist (fn {redex = p,...} =>
-                   fn sof => let
-                        val (hop,args) = strip_comb p
-                      in
-                        safe_insert (hop |-> length args) sof
-                      end handle HOL_ERR _ =>
-                                 (HOL_WARNING "" ""
-                                  "Inconsistent patterning in h.o. match";
-                                  sof))
-        patterns []
-  val tyins = get_type_insts tyavoids realinsts ([],[])
-in
-  (betacounts,
-   mapfilter (fn {redex = x, residue = t} => let
-                   val x' = let val (xn,xty) = dest_var x
-                            in
-                              mk_var(xn, type_subst (#1 tyins) xty)
-                            end
-                 in
-                   if t = x' then failwith "" else {redex = x', residue = t}
-                 end) realinsts,
-   tyins)
-end
-
-fun tyenv_in_dom x (env, idlist) = mem x idlist orelse in_dom x env
-fun tyenv_find_residue x (env, idlist) = if mem x idlist then x
-                                         else find_residue x env
-fun tyenv_safe_insert (t as {redex,residue}) (E as (env, idlist)) = let
-  val existing = tyenv_find_residue redex E
-in
-  if existing = residue then E else failwith "Type bindings clash"
-end handle NOT_FOUND => if redex = residue then (env, redex::idlist)
-                        else (t::env, idlist)
-
-fun beta_normalise0 t = let
-  val bn0 = beta_normalise0
-  fun bn1 t = case bn0 t of NONE => SOME t | x => x
-in
-  case dest_term t of
-    COMB(t1,t2) => let
-    in
-      case Lib.total beta_conv t of
-        NONE => let
-        in
-          case bn0 t1 of
-            NONE => Option.map (fn t2' => mk_comb(t1,t2')) (bn0 t2)
-          | SOME t1' => bn1 (mk_comb(t1',t2))
-        end
-      | SOME t' => bn1 t'
-    end
-  | LAMB(v,t) => Option.map (fn t' => mk_abs(v,t')) (bn0 t)
-  | x => NONE
-end
-
-fun beta_normalise t = case beta_normalise0 t of NONE => t | SOME x => x
-
-fun all_abconv [] [] = true
-  | all_abconv [] _ = false
-  | all_abconv _ [] = false
-  | all_abconv (h1::t1) (h2::t2) =
-     aconv (beta_normalise h1) (beta_normalise h2) andalso all_abconv t1 t2
-
-fun term_homatch tyavoids lconsts tyins (insts, homs) = let
-  (* local constants of both terms and types never change *)
-  val term_homatch = term_homatch tyavoids lconsts
-in
-  if homs = [] then insts
-  else let
-      val (env,ctm,vtm) = hd homs
-    in
-      if is_var vtm then
-        if ctm = vtm then term_homatch tyins (insts, tl homs)
-        else let
-            val newtyins =
-                tyenv_safe_insert (snd (dest_var vtm) |-> type_of ctm) tyins
-            val newinsts = (vtm |-> ctm)::insts
-          in
-            term_homatch newtyins (newinsts, tl homs)
-          end
-      else (* vtm not a var *) let
-          val (vhop, vargs) = strip_comb vtm
-          val afvs = free_varsl vargs
-          val inst_fn = Term.inst (fst tyins)
-        in
-          (let
-             val tmins =
-                 map (fn a =>
-                         (inst_fn a |->
-                                  (find_residue a env
-                                   handle NOT_FOUND =>
-                                          find_residue a insts
-                                   handle NOT_FOUND =>
-                                          if HOLset.member(lconsts, a)
-                                          then a
-                                          else failwith ""))) afvs
-             val pats0 = map inst_fn vargs
-             val pats = map (Term.subst tmins) pats0
-             val vhop' = inst_fn vhop
-             val ictm = list_mk_comb(vhop', pats)
-             val ni = let
-               val (chop,cargs) = strip_comb ctm
-             in
-               if all_abconv cargs pats then
-                 if chop = vhop then insts
-                 else safe_inserta (vhop |-> chop) insts
-               else let
-                   val ginsts = map (fn p => (p |->
-                                                (if is_var p then p
-                                                 else genvar(type_of p))))
-                                    pats
-                   val ctm' = Term.subst ginsts ctm
-                   val gvs = map #residue ginsts
-                   val abstm = list_mk_abs(gvs,ctm')
-                   val vinsts = safe_inserta (vhop |-> abstm) insts
-                   val icpair = (list_mk_comb(vhop',gvs) |-> ctm')
-                 in
-                   icpair::vinsts
-                 end
-             end
-           in
-             term_homatch tyins (ni,tl homs)
-           end) handle HOL_ERR _ => let
-                         val (lc,rc) = dest_comb ctm
-                         val (lv,rv) = dest_comb vtm
-                         val pinsts_homs' =
-                             term_pmatch lconsts env rv rc
-                                         (insts, (env,lc,lv)::(tl homs))
-                         val tyins' =
-                             get_type_insts tyavoids
-                                            (fst pinsts_homs')
-                                            ([], [])
-                       in
-                         term_homatch tyins' pinsts_homs'
-                       end
-        end
-    end
-end
-
-in
-
-fun ho_match_term0 tyavoids lconsts vtm ctm = let
-  val pinsts_homs = term_pmatch lconsts [] vtm ctm ([], [])
-  val tyins = get_type_insts tyavoids (fst pinsts_homs) ([], [])
-  val insts = term_homatch tyavoids lconsts tyins pinsts_homs
-in
-  separate_insts tyavoids insts
-end
-
-fun ho_match_term tyavoids lconsts vtm ctm = let
-  val (bcs, tmins, tyins) = ho_match_term0 tyavoids lconsts vtm ctm
-in
-  (tmins, #1 tyins)
-end handle e => raise (wrap_exn "HolKernel" "ho_match_term" e)
-
-end (* local *)
-
-end

Modified: HOL/src/0/Holmakefile
===================================================================
--- HOL/src/0/Holmakefile	2010-12-15 04:46:47 UTC (rev 8798)
+++ HOL/src/0/Holmakefile	2010-12-15 04:47:29 UTC (rev 8799)
@@ -40,7 +40,7 @@
 Theory-sig.uo: Theory-sig.sml $(PORTABLE_UID) $(FTHEORY_UID)
 	HOLMOSMLC -c -toplevel $(FTHEORY_UI) Theory-sig.sml
 
-Definition-sig.uo: Definition-sig.sml 
+Definition-sig.uo: Definition-sig.sml
 	$(MOSMLC) -c -toplevel Definition-sig.sml
 
 CoreKernel-sig.uo: CoreKernel-sig.sml Net-sig.uo \
@@ -50,7 +50,7 @@
                                Theory-sig.ui TheoryPP-sig.ui Net-sig.ui \
                                Definition-sig.ui CoreKernel-sig.sml
 
-Net-sig.uo: Net-sig.sml 
+Net-sig.uo: Net-sig.sml
 	$(MOSMLC) -c -toplevel Net-sig.sml
 
 Overlay.uo: Overlay.sml CoreKernel-sig.uo Type.uo Term.uo $(FTAG_UID) Thm.uo \
@@ -59,5 +59,3 @@
 	                       Thm.ui TheoryPP.ui Definition.ui $(FTAG_UI) \
                                Theory.ui Net.ui  Overlay.sml
 
-HolKernel.uo: Overlay.uo HolKernel.sml
-	HOLMOSMLC -c -structure Overlay.ui HolKernel.sml

Deleted: HOL/src/experimental-kernel/HolKernel.sml
===================================================================
--- HOL/src/experimental-kernel/HolKernel.sml	2010-12-15 04:46:47 UTC (rev 8798)
+++ HOL/src/experimental-kernel/HolKernel.sml	2010-12-15 04:47:29 UTC (rev 8799)
@@ -1,576 +0,0 @@
-structure HolKernel =
-struct
-
-  open Feedback Globals Lib Type Term Thm Theory Definition
-
-
-(*---------------------------------------------------------------------------
-     Miscellaneous other stuff that builds on top of kernel facilities.
- ---------------------------------------------------------------------------*)
-
-infixr -->;  infix |->;
-
-val ERR = mk_HOL_ERR "HolKernel";
-
-(*---------------------------------------------------------------------------
-          General term operations
- ---------------------------------------------------------------------------*)
-
-fun dest_monop c e M =
- let val (c1,N) = with_exn dest_comb M e
- in if same_const c c1 then N else raise e end
-
-local fun dest tm =
-       let val (Rator,N) = dest_comb tm
-           val (c,M) = dest_comb Rator
-       in (c,(M,N)) end
-in
-fun dest_binop c e tm =
-   let val (c1,pair) = with_exn dest tm e
-   in if same_const c c1 then pair else raise e end
-end
-
-fun dest_triop p e M =
-  let val (f,z) = with_exn dest_comb M e
-      val (x,y) = dest_binop p e f
-  in (x,y,z)
-  end;
-
-local fun dest M = let val (c,Rand) = dest_comb M in (c,dest_abs Rand) end
-in
-fun dest_binder c e M =
-  let val (c1,p) = with_exn dest M e
-  in if same_const c c1 then p else raise e end
-end
-
-
-local fun dest M =
-       let val (Rator,Rand) = dest_comb M in (dest_thy_const Rator,Rand) end
-in
-fun sdest_monop (name,thy) e M =
- let val ({Name,Thy,...},Rand) = with_exn dest M e
- in if Name=name andalso Thy=thy then Rand else raise e
- end;
-end
-
-local fun dest tm =
-       let val (Rator,N) = dest_comb tm
-           val (c,M) = dest_comb Rator
-       in (dest_thy_const c,(M,N))
-       end
-in
-fun sdest_binop (name,thy) e tm =
-   let val ({Name,Thy,...},pair) = with_exn dest tm e
-   in if Name=name andalso Thy=thy then pair else raise e
-   end
-end;
-
-local fun dest M =
-       let val (c, Rand) = dest_comb M
-       in (dest_thy_const c,dest_abs Rand)
-       end
-in
-fun sdest_binder (name,thy) e M =
-  let val ({Name,Thy,...}, p) = with_exn dest M e
-  in if Name=name andalso Thy=thy then p else raise e
-  end
-end;
-
-fun single x = [x];
-
-(* Breaks term down until binop no longer occurs at top level in result list *)
-
-fun strip_binop dest =
- let fun strip A [] = rev A
-       | strip A (h::t) =
-          case dest h
-           of NONE => strip (h::A) t
-            | SOME(c1,c2) => strip A (c1::c2::t)
- in strip [] o single
- end;
-
-(* For right-associative binary operators. Tail recursive. *)
-
-fun spine_binop dest =
- let fun strip A tm =
-       case dest tm
-         of NONE => rev (tm::A)
-          | SOME (l,r) => strip (l::A) r
- in strip []
- end;
-
-(* for left-associative binary operators.  Tail recursive *)
-fun lspine_binop dest = let
-  fun strip A tm =
-      case dest tm of
-        NONE => tm :: A
-      | SOME (l,r) => strip (r::A) l
-in
-  strip []
-end;
-
-(* For right-associative binary operators. Tail recursive. *)
-
-fun list_mk_rbinop mk_binop alist =
-    case List.rev alist of
-      [] => raise ERR "list_mk_rbinop" "empty list"
-    | h::t => rev_itlist mk_binop t h
-
-fun mk_binder c f (p as (Bvar,_)) =
-   mk_comb(inst[alpha |-> type_of Bvar] c, mk_abs p)
-   handle HOL_ERR {message,...} => raise ERR f message;
-
-fun list_mk_fun (dtys, rty) = List.foldr op--> rty dtys
-
-val strip_fun =
-  let val dest = total dom_rng
-      fun strip acc ty =
-          case dest ty
-            of SOME (d,r) => strip (d::acc) r
-             | NONE => (rev acc, ty)
-  in strip []
-  end;
-
-
-val strip_comb =
- let val destc = total dest_comb
-     fun strip rands M =
-      case destc M
-       of NONE => (M, rands)
-        | SOME(Rator,Rand) => strip (Rand::rands) Rator
- in strip []
- end;
-
-
-datatype lambda
-   = VAR   of string * hol_type
-   | CONST of {Name:string, Thy:string, Ty:hol_type}
-   | COMB  of term * term
-   | LAMB  of term * term;
-
-fun dest_term M =
-  COMB(dest_comb M) handle HOL_ERR _ =>
-  LAMB(dest_abs M)  handle HOL_ERR _ =>
-  VAR (dest_var M)  handle HOL_ERR _ =>
-  CONST(dest_thy_const M);
-
-(*---------------------------------------------------------------------------*
- * Used to implement natural deduction style discharging of hypotheses. All  *
- * hypotheses alpha-convertible to the dischargee are removed.               *
- *---------------------------------------------------------------------------*)
-
-fun disch(w,wl) = List.filter (not o Term.aconv w) wl;
-
-
-(*---------------------------------------------------------------------------*
- * Search a term for a sub-term satisfying the predicate P. If application   *
- * of P raises an exception, that propagates to the caller. Therefore,       *
- * P should be a total predicate: otherwise, the caller won't know whether   *
- * the search failed because the sought-for subterm is not there, or because *
- * P failed.                                                                 *
- *---------------------------------------------------------------------------*)
-
-fun find_term P =
- let fun find_tm tm =
-      if P tm then tm else
-      if is_abs tm then find_tm (body tm) else
-      if is_comb tm
-         then let val (Rator,Rand) = dest_comb tm
-              in find_tm Rator handle HOL_ERR _ => find_tm Rand
-              end
-         else raise ERR "find_term" ""
- in find_tm
- end;
-
-(*---------------------------------------------------------------------------
- * find_terms: (term -> bool) -> term -> term list
- *
- *  Find all subterms in a term that satisfy a given predicate p.
- *
- * Added TFM 88.03.31
- *---------------------------------------------------------------------------*)
-
-fun find_terms P =
- let fun accum tl tm =
-      let val tl' = if P tm then tm::tl else tl
-      in accum tl' (body tm)
-         handle HOL_ERR _ =>
-          if is_comb tm
-          then let val (r1,r2) = dest_comb tm
-               in accum (accum tl' r1) r2
-               end
-          else tl'
-      end
- in accum []
- end;
-
-(* ----------------------------------------------------------------------
-    find_maximal_terms[l]
-
-    finds sub-terms within a term, but doesn't look into sub-terms that
-    match the provided predicate.  The find_maximal_termsl version
-    returns the terms as a list rather than a set.
-   ---------------------------------------------------------------------- *)
-
-fun find_maximal_terms P t = let
-  fun recurse acc tlist =
-      case tlist of
-        [] => acc
-      | t::ts =>
-        if P t then recurse (HOLset.add(acc, t)) ts
-        else
-          case dest_term t of
-            COMB(f,x) => recurse acc (f::x::ts)
-          | LAMB(v,b) => recurse acc (b::ts)
-          | _ => recurse acc ts
-in
-  recurse empty_tmset [t]
-end
-
-fun find_maximal_termsl P t = HOLset.listItems (find_maximal_terms P t)
-
-(* ----------------------------------------------------------------------
-    term_size
-
-    Returns a term's size.  There's no logical significance to this
-    number, but it can be useful.
-   ---------------------------------------------------------------------- *)
-
-fun term_size t = let
-  fun recurse acc tlist =
-      case tlist of
-        [] => acc
-      | t::ts =>
-        case dest_term t of
-          COMB(f, x) => recurse acc (f::x::ts)
-        | LAMB(v,b) => recurse (1 + acc) (b::ts)
-        | _ => recurse (1 + acc) ts
-in
-  recurse 0 [t]
-end
-
-(*---------------------------------------------------------------------------
- * Subst_occs
- * Put a new variable in tm2 at designated (and free) occurrences of redex.
- * Rebuilds the entire term.
- *---------------------------------------------------------------------------*)
-
-local
-fun splice ({redex,...}:{redex:term,residue:term}) v occs tm2 =
-   let fun graft (r as {occs=[], ...}) = r
-         | graft {tm, occs, count} =
-          if term_eq redex tm
-          then if (List.hd occs=count+1)
-               then {tm=v, occs=List.tl occs, count=count+1}
-               else {tm=tm, occs=occs, count=count+1}
-          else if (is_comb tm)
-               then let val (Rator, Rand) = dest_comb tm
-                        val {tm=Rator', occs=occs', count=count'} =
-                                        graft {tm=Rator,occs=occs,count=count}
-                        val {tm=Rand', occs=occs'', count=count''} =
-                                        graft {tm=Rand,occs=occs',count=count'}
-                    in {tm=mk_comb(Rator', Rand'),
-                        occs=occs'', count=count''}
-                    end
-               else if is_abs tm
-                    then let val (Bvar,Body) = dest_abs tm
-                             val {tm, count, occs} =
-                                        graft{tm=Body,count=count,occs=occs}
-                         in {tm=mk_abs(Bvar, tm),
-                             count=count, occs=occs}
-                         end
-                    else {tm=tm, occs=occs, count=count}
-   in #tm(graft {tm=tm2, occs=occs, count=0})
-   end
-
-fun rev_itlist3 f L1 L2 L3 base_value =
- let fun rev_it3 (a::rst1) (b::rst2) (c::rst3) base =
-             rev_it3 rst1 rst2 rst3 (f a b c base)
-       | rev_it3 [] [] [] base = base
-       | rev_it3 _ _ _ _ = raise ERR "rev_itlist3"
-                                  "not all lists have same size"
- in rev_it3 L1 L2 L3 base_value
- end
-
-val sort = Lib.sort (Lib.curry (op <=) : int -> int -> bool)
-in
-fun subst_occs occ_lists tm_subst tm =
-   let val occ_lists' = map sort occ_lists
-       val (new_vars,theta) =
-               Lib.itlist (fn {redex,residue} => fn (V,T) =>
-                         let val v = genvar(type_of redex)
-                         in (v::V,  (v |-> residue)::T)  end)
-                      tm_subst ([],[])
-       val template = rev_itlist3 splice tm_subst new_vars occ_lists' tm
-   in subst theta template
-   end
-end;
-
-
-(*---------------------------------------------------------------------------
-       Higher order matching (from jrh via Michael Norrish - June 2001)
- ---------------------------------------------------------------------------*)
-
-local
-  exception NOT_FOUND
-  fun find_residue red [] = raise NOT_FOUND
-    | find_residue red ({redex,residue}::rest) = if red = redex then residue
-                                                 else find_residue red rest
-  fun in_dom x [] = false
-    | in_dom x ({redex,residue}::rest) = (x = redex) orelse in_dom x rest
-  fun safe_insert (n as {redex,residue}) l = let
-    val z = find_residue redex l
-  in
-    if residue = z then l
-    else failwith "match: safe_insert"
-  end handle NOT_FOUND => n::l  (* binding not there *)
-  fun safe_inserta (n as {redex,residue}) l = let
-    val z = find_residue redex l
-  in
-    if aconv residue z then l
-    else failwith "match: safe_inserta"
-  end handle NOT_FOUND => n::l
-  val mk_dummy = let
-    val name = fst(dest_var(genvar Type.alpha))
-  in fn ty => mk_var(name, ty)
-  end
-
-
-  fun term_pmatch lconsts env vtm ctm (sofar as (insts,homs)) =
-    if is_var vtm then let
-        val ctm' = find_residue vtm env
-      in
-        if ctm' = ctm then sofar else failwith "term_pmatch"
-      end handle NOT_FOUND =>
-                 if HOLset.member(lconsts, vtm) then
-                   if ctm = vtm then sofar
-                   else
-                     failwith "term_pmatch: can't instantiate local constant"
-                 else (safe_inserta (vtm |-> ctm) insts, homs)
-    else if is_const vtm then let
-        val {Thy = vthy, Name = vname, Ty = vty} = dest_thy_const vtm
-        val {Thy = cthy, Name = cname, Ty = cty} = dest_thy_const ctm
-      in
-        if vname = cname andalso vthy = cthy then
-          if cty = vty then sofar
-          else (safe_insert (mk_dummy vty |-> mk_dummy cty) insts, homs)
-        else failwith "term_pmatch"
-      end
-    else if is_abs vtm then let
-        val (vv,vbod) = dest_abs vtm
-        val (cv,cbod) = dest_abs ctm
-        val (_, vty) = dest_var vv
-        val (_, cty) = dest_var cv
-        val sofar' = (safe_insert(mk_dummy vty |-> mk_dummy cty) insts, homs)
-      in
-        term_pmatch lconsts ((vv |-> cv)::env) vbod cbod sofar'
-      end
-    else let
-        val vhop = repeat rator vtm
-      in
-        if is_var vhop andalso not (HOLset.member(lconsts, vhop)) andalso
-           not (in_dom vhop env)
-        then let
-            val vty = type_of vtm
-            val cty = type_of ctm
-            val insts' = if vty = cty then insts
-                         else safe_insert (mk_dummy vty |-> mk_dummy cty) insts
-          in
-            (insts', (env,ctm,vtm)::homs)
-          end
-        else let
-            val (lv,rv) = dest_comb vtm
-            val (lc,rc) = dest_comb ctm
-            val sofar' = term_pmatch lconsts env lv lc sofar
-          in
-            term_pmatch lconsts env rv rc sofar'
-          end
-      end
-
-(*
-fun get_type_insts avoids L =
- let val avtys = itlist (fn ty => fn (p,o) => (ty-->p, ty-->o))
-                        avoids (bool,bool)
-     val (pat,ob) = itlist (fn {redex,residue} => fn (pat,ob) =>
-                               (type_of redex-->pat, type_of residue-->ob))
-                         L avtys
-
- in match_type pat ob
- end
-
-fun get_type_insts avoids L =
- let val tytheta = itlist (fn {redex,residue} =>
-          match_type_in_context (snd(dest_var redex)) (type_of residue))
-                     L []
- in if null(intersect avoids (map #residue tytheta))
-    then tytheta
-    else raise ERR "get_type_insts" "attempt to bind fixed type variable"
- end
-*)
-fun get_type_insts avoids L (tyS,Id) =
- itlist (fn {redex,residue} => fn Theta =>
-          raw_match_type (snd(dest_var redex)) (type_of residue) Theta)
-       L (tyS,union avoids Id)
-
-fun separate_insts tyavoids insts = let
-  val (realinsts, patterns) = partition (is_var o #redex) insts
-  val betacounts =
-      if patterns = [] then []
-      else
-        itlist (fn {redex = p,...} =>
-                   fn sof => let
-                        val (hop,args) = strip_comb p
-                      in
-                        safe_insert (hop |-> length args) sof
-                      end handle HOL_ERR _ =>
-                                 (HOL_WARNING "" ""
-                                  "Inconsistent patterning in h.o. match";
-                                  sof))
-        patterns []
-  val tyins = get_type_insts tyavoids realinsts ([],[])
-in
-  (betacounts,
-   mapfilter (fn {redex = x, residue = t} => let
-                   val x' = let val (xn,xty) = dest_var x
-                            in
-                              mk_var(xn, type_subst (#1 tyins) xty)
-                            end
-                 in
-                   if t = x' then failwith "" else {redex = x', residue = t}
-                 end) realinsts,
-   tyins)
-end
-
-fun tyenv_in_dom x (env, idlist) = mem x idlist orelse in_dom x env
-fun tyenv_find_residue x (env, idlist) = if mem x idlist then x
-                                         else find_residue x env
-fun tyenv_safe_insert (t as {redex,residue}) (E as (env, idlist)) = let
-  val existing = tyenv_find_residue redex E
-in
-  if existing = residue then E else failwith "Type bindings clash"
-end handle NOT_FOUND => if redex = residue then (env, redex::idlist)
-                        else (t::env, idlist)
-
-fun beta_normalise0 t = let
-  val bn0 = beta_normalise0
-  fun bn1 t = case bn0 t of NONE => SOME t | x => x
-in
-  case dest_term t of
-    COMB(t1,t2) => let
-    in
-      case Lib.total beta_conv t of
-        NONE => let
-        in
-          case bn0 t1 of
-            NONE => Option.map (fn t2' => mk_comb(t1,t2')) (bn0 t2)
-          | SOME t1' => bn1 (mk_comb(t1',t2))
-        end
-      | SOME t' => bn1 t'
-    end
-  | LAMB(v,t) => Option.map (fn t' => mk_abs(v,t')) (bn0 t)
-  | x => NONE
-end
-
-fun beta_normalise t = case beta_normalise0 t of NONE => t | SOME x => x
-
-fun all_abconv [] [] = true
-  | all_abconv [] _ = false
-  | all_abconv _ [] = false
-  | all_abconv (h1::t1) (h2::t2) =
-     aconv (beta_normalise h1) (beta_normalise h2) andalso all_abconv t1 t2
-
-fun term_homatch tyavoids lconsts tyins (insts, homs) = let
-  (* local constants of both terms and types never change *)
-  val term_homatch = term_homatch tyavoids lconsts
-in
-  if homs = [] then insts
-  else let
-      val (env,ctm,vtm) = hd homs
-    in
-      if is_var vtm then
-        if ctm = vtm then term_homatch tyins (insts, tl homs)
-        else let
-            val newtyins =
-                tyenv_safe_insert (snd (dest_var vtm) |-> type_of ctm) tyins
-            val newinsts = (vtm |-> ctm)::insts
-          in
-            term_homatch newtyins (newinsts, tl homs)
-          end
-      else (* vtm not a var *) let
-          val (vhop, vargs) = strip_comb vtm
-          val afvs = free_varsl vargs
-          val inst_fn = Term.inst (fst tyins)
-        in
-          (let
-             val tmins =
-                 map (fn a =>
-                         (inst_fn a |->
-                                  (find_residue a env
-                                   handle NOT_FOUND =>
-                                          find_residue a insts
-                                   handle NOT_FOUND =>
-                                          if HOLset.member(lconsts, a)
-                                          then a
-                                          else failwith ""))) afvs
-             val pats0 = map inst_fn vargs
-             val pats = map (Term.subst tmins) pats0
-             val vhop' = inst_fn vhop
-             val ictm = list_mk_comb(vhop', pats)
-             val ni = let
-               val (chop,cargs) = strip_comb ctm
-             in
-               if all_abconv cargs pats then
-                 if chop = vhop then insts
-                 else safe_inserta (vhop |-> chop) insts
-               else let
-                   val ginsts = map (fn p => (p |->
-                                                (if is_var p then p
-                                                 else genvar(type_of p))))
-                                    pats
-                   val ctm' = Term.subst ginsts ctm
-                   val gvs = map #residue ginsts
-                   val abstm = list_mk_abs(gvs,ctm')
-                   val vinsts = safe_inserta (vhop |-> abstm) insts
-                   val icpair = (list_mk_comb(vhop',gvs) |-> ctm')
-                 in
-                   icpair::vinsts
-                 end
-             end
-           in
-             term_homatch tyins (ni,tl homs)
-           end) handle HOL_ERR _ => let
-                         val (lc,rc) = dest_comb ctm
-                         val (lv,rv) = dest_comb vtm
-                         val pinsts_homs' =
-                             term_pmatch lconsts env rv rc
-                                         (insts, (env,lc,lv)::(tl homs))
-                         val tyins' =
-                             get_type_insts tyavoids
-                                            (fst pinsts_homs')
-                                            ([], [])
-                       in
-                         term_homatch tyins' pinsts_homs'
-                       end
-        end
-    end
-end
-
-in
-
-fun ho_match_term0 tyavoids lconsts vtm ctm = let
-  val pinsts_homs = term_pmatch lconsts [] vtm ctm ([], [])
-  val tyins = get_type_insts tyavoids (fst pinsts_homs) ([], [])
-  val insts = term_homatch tyavoids lconsts tyins pinsts_homs
-in
-  separate_insts tyavoids insts
-end
-
-fun ho_match_term tyavoids lconsts vtm ctm = let
-  val (bcs, tmins, tyins) = ho_match_term0 tyavoids lconsts vtm ctm
-in
-  (tmins, #1 tyins)
-end handle e => raise (wrap_exn "HolKernel" "ho_match_term" e)
-
-end (* local *)
-
-end

Copied: HOL/src/postkernel/HolKernel.sml (from rev 8798, HOL/src/0/HolKernel.sml)
===================================================================
--- HOL/src/postkernel/HolKernel.sml	                        (rev 0)
+++ HOL/src/postkernel/HolKernel.sml	2010-12-15 04:47:29 UTC (rev 8799)
@@ -0,0 +1,588 @@
+structure HolKernel =
+struct
+
+  open Feedback Globals Lib Type Term Thm Theory Definition
+
+
+(*---------------------------------------------------------------------------
+     Miscellaneous other stuff that builds on top of kernel facilities.
+ ---------------------------------------------------------------------------*)
+
+infixr -->;  infix |->;
+
+val ERR = mk_HOL_ERR "HolKernel";
+
+(*---------------------------------------------------------------------------
+          General term operations
+ ---------------------------------------------------------------------------*)
+
+fun dest_monop c e M =
+ let val (c1,N) = with_exn dest_comb M e
+ in if same_const c c1 then N else raise e end
+
+local fun dest tm =
+       let val (Rator,N) = dest_comb tm
+           val (c,M) = dest_comb Rator
+       in (c,(M,N)) end
+in
+fun dest_binop c e tm =
+   let val (c1,pair) = with_exn dest tm e
+   in if same_const c c1 then pair else raise e end
+end
+
+fun dest_triop p e M =
+  let val (f,z) = with_exn dest_comb M e
+      val (x,y) = dest_binop p e f
+  in (x,y,z)
+  end;
+
+(*---------------------------------------------------------------------------*)
+(* Take a binder apart. Fails on paired binders.                             *)
+(*---------------------------------------------------------------------------*)
+
+local
+  fun dest M =
+    let val (c,Rand) = dest_comb M
+    in (c,dest_abs Rand) end
+in
+fun dest_binder c e M =
+  let val (c1,p) = with_exn dest M e
+  in if same_const c c1 then p else raise e end
+end
+
+
+local fun dest M =
+       let val (Rator,Rand) = dest_comb M in (dest_thy_const Rator,Rand) end
+in
+fun sdest_monop (name,thy) e M =
+ let val ({Name,Thy,...},Rand) = with_exn dest M e
+ in if Name=name andalso Thy=thy then Rand else raise e
+ end;
+end
+
+local fun dest tm =
+       let val (Rator,N) = dest_comb tm
+           val (c,M) = dest_comb Rator
+       in (dest_thy_const c,(M,N))
+       end
+in
+fun sdest_binop (name,thy) e tm =
+   let val ({Name,Thy,...},pair) = with_exn dest tm e
+   in if Name=name andalso Thy=thy then pair else raise e
+   end
+end;
+
+local fun dest M =
+       let val (c, Rand) = dest_comb M
+       in (dest_thy_const c,dest_abs Rand)
+       end
+in
+fun sdest_binder (name,thy) e M =
+  let val ({Name,Thy,...}, p) = with_exn dest M e
+  in if Name=name andalso Thy=thy then p else raise e
+  end
+end;
+
+fun single x = [x];
+
+(* Breaks term down until binop no longer occurs at top level in result list *)
+
+fun strip_binop dest =
+ let fun strip A [] = rev A
+       | strip A (h::t) =
+          case dest h
+           of NONE => strip (h::A) t
+            | SOME(c1,c2) => strip A (c1::c2::t)
+ in strip [] o single
+ end;
+
+(* For right-associative binary operators. Tail recursive. *)
+
+fun spine_binop dest =
+ let fun strip A tm =
+       case dest tm
+         of NONE => rev (tm::A)
+          | SOME (l,r) => strip (l::A) r
+ in strip []
+ end;
+
+(* for left-associative binary operators.  Tail recursive *)
+fun lspine_binop dest = let
+  fun strip A tm =
+      case dest tm of
+        NONE => tm :: A
+      | SOME (l,r) => strip (r::A) l
+in
+  strip []
+end;
+
+(* For right-associative binary operators. Tail recursive. *)
+
+fun list_mk_rbinop mk_binop alist =
+    case List.rev alist of
+      [] => raise ERR "list_mk_rbinop" "empty list"
+    | h::t => rev_itlist mk_binop t h
+
+(* For left-associative binary operators. Tail recursive. *)
+
+fun list_mk_lbinop _ [] = raise ERR "list_mk_lbinop" "empty list"
+  | list_mk_lbinop mk_binop (h::t) = rev_itlist (C mk_binop) t h;
+
+fun mk_binder c f (p as (Bvar,_)) =
+   mk_comb(inst[alpha |-> type_of Bvar] c, mk_abs p)
+   handle HOL_ERR {message,...} => raise ERR f message;
+
+fun list_mk_fun (dtys, rty) = List.foldr op--> rty dtys
+
+val strip_fun =
+  let val dest = total dom_rng
+      fun strip acc ty =
+          case dest ty
+            of SOME (d,r) => strip (d::acc) r
+             | NONE => (rev acc, ty)
+  in strip []
+  end;
+
+
+val strip_comb =
+ let val destc = total dest_comb
+     fun strip rands M =
+      case destc M
+       of NONE => (M, rands)
+        | SOME(Rator,Rand) => strip (Rand::rands) Rator
+ in strip []
+ end;
+
+
+datatype lambda
+   = VAR   of string * hol_type
+   | CONST of {Name:string, Thy:string, Ty:hol_type}
+   | COMB  of term * term
+   | LAMB  of term * term;
+
+fun dest_term M =
+  COMB(dest_comb M) handle HOL_ERR _ =>
+  LAMB(dest_abs M)  handle HOL_ERR _ =>
+  VAR (dest_var M)  handle HOL_ERR _ =>
+  CONST(dest_thy_const M);
+
+(*---------------------------------------------------------------------------*
+ * Used to implement natural deduction style discharging of hypotheses. All  *
+ * hypotheses alpha-convertible to the dischargee are removed.               *
+ *---------------------------------------------------------------------------*)
+
+fun disch(w,wl) = List.filter (not o Term.aconv w) wl;
+
+
+(*---------------------------------------------------------------------------*
+ * Search a term for a sub-term satisfying the predicate P. If application   *
+ * of P raises an exception, that propagates to the caller. Therefore,       *
+ * P should be a total predicate: otherwise, the caller won't know whether   *
+ * the search failed because the sought-for subterm is not there, or because *
+ * P failed.                                                                 *
+ *---------------------------------------------------------------------------*)
+
+fun find_term P =
+ let fun find_tm tm =
+      if P tm then tm else
+      if is_abs tm then find_tm (body tm) else
+      if is_comb tm
+         then let val (Rator,Rand) = dest_comb tm
+              in find_tm Rator handle HOL_ERR _ => find_tm Rand
+              end
+         else raise ERR "find_term" ""
+ in find_tm
+ end;
+
+(*---------------------------------------------------------------------------
+ * find_terms: (term -> bool) -> term -> term list
+ *
+ *  Find all subterms in a term that satisfy a given predicate p.
+ *
+ * Added TFM 88.03.31
+ *---------------------------------------------------------------------------*)
+
+fun find_terms P =
+ let fun accum tl tm =
+      let val tl' = if P tm then tm::tl else tl
+      in accum tl' (body tm)
+         handle HOL_ERR _ =>
+          if is_comb tm
+          then let val (r1,r2) = dest_comb tm
+               in accum (accum tl' r1) r2
+               end
+          else tl'
+      end
+ in accum []
+ end;
+
+(* ----------------------------------------------------------------------
+    find_maximal_terms[l]
+
+    finds sub-terms within a term, but doesn't look into sub-terms that
+    match the provided predicate.  The find_maximal_termsl version
+    returns the terms as a list rather than a set.
+   ---------------------------------------------------------------------- *)
+
+fun find_maximal_terms P t = let
+  fun recurse acc tlist =
+      case tlist of
+        [] => acc
+      | t::ts =>
+        if P t then recurse (HOLset.add(acc, t)) ts
+        else
+          case dest_term t of
+            COMB(f,x) => recurse acc (f::x::ts)
+          | LAMB(v,b) => recurse acc (b::ts)
+          | _ => recurse acc ts
+in
+  recurse empty_tmset [t]
+end
+
+fun find_maximal_termsl P t = HOLset.listItems (find_maximal_terms P t)
+
+(* ----------------------------------------------------------------------
+    term_size
+
+    Returns a term's size.  There's no logical significance to this
+    number, but it can be useful.
+   ---------------------------------------------------------------------- *)
+
+fun term_size t = let
+  fun recurse acc tlist =
+      case tlist of
+        [] => acc
+      | t::ts =>
+        case dest_term t of
+          COMB(f, x) => recurse acc (f::x::ts)
+        | LAMB(v,b) => recurse (1 + acc) (b::ts)
+        | _ => recurse (1 + acc) ts
+in
+  recurse 0 [t]
+end
+
+(*---------------------------------------------------------------------------
+ * Subst_occs
+ * Put a new variable in tm2 at designated (and free) occurrences of redex.
+ * Rebuilds the entire term.
+ *---------------------------------------------------------------------------*)
+
+local
+fun splice ({redex,...}:{redex:term,residue:term}) v occs tm2 =
+   let fun graft (r as {occs=[], ...}) = r
+         | graft {tm, occs, count} =
+          if term_eq redex tm
+          then if (List.hd occs=count+1)
+               then {tm=v, occs=List.tl occs, count=count+1}
+               else {tm=tm, occs=occs, count=count+1}
+          else if (is_comb tm)
+               then let val (Rator, Rand) = dest_comb tm
+                        val {tm=Rator', occs=occs', count=count'} =
+                                        graft {tm=Rator,occs=occs,count=count}
+                        val {tm=Rand', occs=occs'', count=count''} =
+                                        graft {tm=Rand,occs=occs',count=count'}
+                    in {tm=mk_comb(Rator', Rand'),
+                        occs=occs'', count=count''}
+                    end
+               else if is_abs tm
+                    then let val (Bvar,Body) = dest_abs tm
+                             val {tm, count, occs} =
+                                        graft{tm=Body,count=count,occs=occs}
+                         in {tm=mk_abs(Bvar, tm),
+                             count=count, occs=occs}
+                         end
+                    else {tm=tm, occs=occs, count=count}
+   in #tm(graft {tm=tm2, occs=occs, count=0})
+   end
+
+fun rev_itlist3 f L1 L2 L3 base_value =
+ let fun rev_it3 (a::rst1) (b::rst2) (c::rst3) base =
+             rev_it3 rst1 rst2 rst3 (f a b c base)
+       | rev_it3 [] [] [] base = base
+       | rev_it3 _ _ _ _ = raise ERR "rev_itlist3"
+                                  "not all lists have same size"
+ in rev_it3 L1 L2 L3 base_value
+ end
+
+val sort = Lib.sort (Lib.curry (op <=) : int -> int -> bool)
+in
+fun subst_occs occ_lists tm_subst tm =
+   let val occ_lists' = map sort occ_lists
+       val (new_vars,theta) =
+               Lib.itlist (fn {redex,residue} => fn (V,T) =>
+                         let val v = genvar(type_of redex)
+                         in (v::V,  (v |-> residue)::T)  end)
+                      tm_subst ([],[])
+       val template = rev_itlist3 splice tm_subst new_vars occ_lists' tm
+   in subst theta template
+   end
+end;
+
+
+(*---------------------------------------------------------------------------
+       Higher order matching (from jrh via Michael Norrish - June 2001)
+ ---------------------------------------------------------------------------*)
+
+local
+  exception NOT_FOUND
+  fun find_residue red [] = raise NOT_FOUND
+    | find_residue red ({redex,residue}::rest) = if red = redex then residue
+                                                 else find_residue red rest
+  fun in_dom x [] = false
+    | in_dom x ({redex,residue}::rest) = (x = redex) orelse in_dom x rest
+  fun safe_insert (n as {redex,residue}) l = let
+    val z = find_residue redex l
+  in
+    if residue = z then l
+    else failwith "match: safe_insert"
+  end handle NOT_FOUND => n::l  (* binding not there *)
+  fun safe_inserta (n as {redex,residue}) l = let
+    val z = find_residue redex l
+  in
+    if aconv residue z then l
+    else failwith "match: safe_inserta"
+  end handle NOT_FOUND => n::l
+  val mk_dummy = let
+    val name = fst(dest_var(genvar Type.alpha))
+  in fn ty => mk_var(name, ty)
+  end
+
+
+  fun term_pmatch lconsts env vtm ctm (sofar as (insts,homs)) =
+    if is_var vtm then let
+        val ctm' = find_residue vtm env
+      in
+        if ctm' = ctm then sofar else failwith "term_pmatch"
+      end handle NOT_FOUND =>
+                 if HOLset.member(lconsts, vtm) then
+                   if ctm = vtm then sofar
+                   else
+                     failwith "term_pmatch: can't instantiate local constant"
+                 else (safe_inserta (vtm |-> ctm) insts, homs)
+    else if is_const vtm then let
+        val {Thy = vthy, Name = vname, Ty = vty} = dest_thy_const vtm
+        val {Thy = cthy, Name = cname, Ty = cty} = dest_thy_const ctm
+      in
+        if vname = cname andalso vthy = cthy then
+          if cty = vty then sofar
+          else (safe_insert (mk_dummy vty |-> mk_dummy cty) insts, homs)
+        else failwith "term_pmatch"
+      end
+    else if is_abs vtm then let
+        val (vv,vbod) = dest_abs vtm
+        val (cv,cbod) = dest_abs ctm
+        val (_, vty) = dest_var vv
+        val (_, cty) = dest_var cv
+        val sofar' = (safe_insert(mk_dummy vty |-> mk_dummy cty) insts, homs)
+      in
+        term_pmatch lconsts ((vv |-> cv)::env) vbod cbod sofar'
+      end
+    else let
+        val vhop = repeat rator vtm
+      in
+        if is_var vhop andalso not (HOLset.member(lconsts, vhop)) andalso
+           not (in_dom vhop env)
+        then let
+            val vty = type_of vtm
+            val cty = type_of ctm
+            val insts' = if vty = cty then insts
+                         else safe_insert (mk_dummy vty |-> mk_dummy cty) insts
+          in
+            (insts', (env,ctm,vtm)::homs)
+          end
+        else let
+            val (lv,rv) = dest_comb vtm
+            val (lc,rc) = dest_comb ctm
+            val sofar' = term_pmatch lconsts env lv lc sofar
+          in
+            term_pmatch lconsts env rv rc sofar'
+          end
+      end
+
+(*
+fun get_type_insts avoids L =
+ let val avtys = itlist (fn ty => fn (p,o) => (ty-->p, ty-->o))
+                        avoids (bool,bool)
+     val (pat,ob) = itlist (fn {redex,residue} => fn (pat,ob) =>
+                               (type_of redex-->pat, type_of residue-->ob))
+                         L avtys
+
+ in match_type pat ob
+ end
+
+fun get_type_insts avoids L =
+ let val tytheta = itlist (fn {redex,residue} =>
+          match_type_in_context (snd(dest_var redex)) (type_of residue))
+                     L []
+ in if null(intersect avoids (map #residue tytheta))
+    then tytheta
+    else raise ERR "get_type_insts" "attempt to bind fixed type variable"
+ end
+*)
+fun get_type_insts avoids L (tyS,Id) =
+ itlist (fn {redex,residue} => fn Theta =>
+          raw_match_type (snd(dest_var redex)) (type_of residue) Theta)
+       L (tyS,union avoids Id)
+
+fun separate_insts tyavoids insts = let
+  val (realinsts, patterns) = partition (is_var o #redex) insts
+  val betacounts =
+      if patterns = [] then []
+      else
+        itlist (fn {redex = p,...} =>
+                   fn sof => let
+                        val (hop,args) = strip_comb p
+                      in
+                        safe_insert (hop |-> length args) sof
+                      end handle HOL_ERR _ =>
+                                 (HOL_WARNING "" ""
+                                  "Inconsistent patterning in h.o. match";
+                                  sof))
+        patterns []
+  val tyins = get_type_insts tyavoids realinsts ([],[])
+in
+  (betacounts,
+   mapfilter (fn {redex = x, residue = t} => let
+                   val x' = let val (xn,xty) = dest_var x
+                            in
+                              mk_var(xn, type_subst (#1 tyins) xty)
+                            end
+                 in
+                   if t = x' then failwith "" else {redex = x', residue = t}
+                 end) realinsts,
+   tyins)
+end
+
+fun tyenv_in_dom x (env, idlist) = mem x idlist orelse in_dom x env
+fun tyenv_find_residue x (env, idlist) = if mem x idlist then x
+                                         else find_residue x env
+fun tyenv_safe_insert (t as {redex,residue}) (E as (env, idlist)) = let
+  val existing = tyenv_find_residue redex E
+in
+  if existing = residue then E else failwith "Type bindings clash"
+end handle NOT_FOUND => if redex = residue then (env, redex::idlist)
+                        else (t::env, idlist)
+
+fun beta_normalise0 t = let
+  val bn0 = beta_normalise0
+  fun bn1 t = case bn0 t of NONE => SOME t | x => x
+in
+  case dest_term t of
+    COMB(t1,t2) => let
+    in
+      case Lib.total beta_conv t of
+        NONE => let
+        in
+          case bn0 t1 of
+            NONE => Option.map (fn t2' => mk_comb(t1,t2')) (bn0 t2)
+          | SOME t1' => bn1 (mk_comb(t1',t2))
+        end
+      | SOME t' => bn1 t'
+    end
+  | LAMB(v,t) => Option.map (fn t' => mk_abs(v,t')) (bn0 t)
+  | x => NONE
+end
+
+fun beta_normalise t = case beta_normalise0 t of NONE => t | SOME x => x
+
+fun all_abconv [] [] = true
+  | all_abconv [] _ = false
+  | all_abconv _ [] = false
+  | all_abconv (h1::t1) (h2::t2) =
+     aconv (beta_normalise h1) (beta_normalise h2) andalso all_abconv t1 t2
+
+fun term_homatch tyavoids lconsts tyins (insts, homs) = let
+  (* local constants of both terms and types never change *)
+  val term_homatch = term_homatch tyavoids lconsts
+in
+  if homs = [] then insts
+  else let
+      val (env,ctm,vtm) = hd homs
+    in
+      if is_var vtm then
+        if ctm = vtm then term_homatch tyins (insts, tl homs)
+        else let
+            val newtyins =
+                tyenv_safe_insert (snd (dest_var vtm) |-> type_of ctm) tyins
+            val newinsts = (vtm |-> ctm)::insts
+          in
+            term_homatch newtyins (newinsts, tl homs)
+          end
+      else (* vtm not a var *) let
+          val (vhop, vargs) = strip_comb vtm
+          val afvs = free_varsl vargs
+          val inst_fn = Term.inst (fst tyins)
+        in
+          (let
+             val tmins =
+                 map (fn a =>
+                         (inst_fn a |->
+                                  (find_residue a env
+                                   handle NOT_FOUND =>
+                                          find_residue a insts
+                                   handle NOT_FOUND =>
+                                          if HOLset.member(lconsts, a)
+                                          then a
+                                          else failwith ""))) afvs
+             val pats0 = map inst_fn vargs
+             val pats = map (Term.subst tmins) pats0
+             val vhop' = inst_fn vhop
+             val ictm = list_mk_comb(vhop', pats)
+             val ni = let
+               val (chop,cargs) = strip_comb ctm
+             in
+               if all_abconv cargs pats then
+                 if chop = vhop then insts
+                 else safe_inserta (vhop |-> chop) insts
+               else let
+                   val ginsts = map (fn p => (p |->
+                                                (if is_var p then p
+                                                 else genvar(type_of p))))
+                                    pats
+                   val ctm' = Term.subst ginsts ctm
+                   val gvs = map #residue ginsts
+                   val abstm = list_mk_abs(gvs,ctm')
+                   val vinsts = safe_inserta (vhop |-> abstm) insts
+                   val icpair = (list_mk_comb(vhop',gvs) |-> ctm')
+                 in
+                   icpair::vinsts
+                 end
+             end
+           in
+             term_homatch tyins (ni,tl homs)
+           end) handle HOL_ERR _ => let
+                         val (lc,rc) = dest_comb ctm
+                         val (lv,rv) = dest_comb vtm
+                         val pinsts_homs' =
+                             term_pmatch lconsts env rv rc
+                                         (insts, (env,lc,lv)::(tl homs))
+                         val tyins' =
+                             get_type_insts tyavoids
+                                            (fst pinsts_homs')
+                                            ([], [])
+                       in
+                         term_homatch tyins' pinsts_homs'
+                       end
+        end
+    end
+end
+
+in
+
+fun ho_match_term0 tyavoids lconsts vtm ctm = let
+  val pinsts_homs = term_pmatch lconsts [] vtm ctm ([], [])
+  val tyins = get_type_insts tyavoids (fst pinsts_homs) ([], [])
+  val insts = term_homatch tyavoids lconsts tyins pinsts_homs
+in
+  separate_insts tyavoids insts
+end
+
+fun ho_match_term tyavoids lconsts vtm ctm = let
+  val (bcs, tmins, tyins) = ho_match_term0 tyavoids lconsts vtm ctm
+in
+  (tmins, #1 tyins)
+end handle e => raise (wrap_exn "HolKernel" "ho_match_term" e)
+
+end (* local *)
+
+end


Property changes on: HOL/src/postkernel/HolKernel.sml
___________________________________________________________________
Added: svn:mime-type
   + text/plain
Added: svn:keywords
   + Author Date Id Revision
Added: svn:eol-style
   + native

Modified: HOL/tools/build-sequence
===================================================================
--- HOL/tools/build-sequence	2010-12-15 04:46:47 UTC (rev 8798)
+++ HOL/tools/build-sequence	2010-12-15 04:47:29 UTC (rev 8799)
@@ -37,6 +37,7 @@
 src/portableML
 src/prekernel
 **KERNEL**
+src/postkernel
 # these three directories are required to even run hol.bare.unquote
 src/parse
 src/bool


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 8802
          http://hol.svn.sourceforge.net/hol/?rev=8802&view=rev
Author:   michaeln
Date:     2010-12-16 03:54:31 +0000 (Thu, 16 Dec 2010)

Log Message:
-----------
BIG refactor: mainly to allow stdknl to use SharingTables technology.

SharingTables implements hash-consing for types as they are written
out to disk.  This can make a big difference to the theory file size,
and thus to theory-loading times.

The big visible change is that Theory, TheoryPP and Definition are no
longer really part of the kernel, and are found in src/postkernel
instead.  They don't need to know about secret implementation details
in terms, types or theorems.  They do need to have access to

  Term.{write,read}_raw

and primitive definition principles (which are in Thm).

Another API change is that Tags no longer use user-visible string refs
to record use of axioms.  Instead, the refs are hidden behind a new
Nonce type.  This in turn means that the Tag.axioms_of function can
move to be visible to all users after the kernel.  (If we kept the
axioms as string refs, users could alter the strings being pointed
to.)

Modified Paths:
--------------
    HOL/src/0/CoreKernel-sig.sml
    HOL/src/0/Holmakefile
    HOL/src/0/Overlay.sml
    HOL/src/0/Raw-sig.sml
    HOL/src/0/Term.sig
    HOL/src/0/Term.sml
    HOL/src/0/Thm.sml
    HOL/src/0/Type.sig
    HOL/src/0/Type.sml
    HOL/src/experimental-kernel/Holmakefile
    HOL/src/experimental-kernel/Term.sig
    HOL/src/experimental-kernel/Term.sml
    HOL/src/experimental-kernel/Thm.sig
    HOL/src/experimental-kernel/Type.sig
    HOL/src/prekernel/FinalTag-sig.sml
    HOL/src/prekernel/FinalTerm-sig.sml
    HOL/src/prekernel/FinalType-sig.sml
    HOL/src/prekernel/Holmakefile
    HOL/src/prekernel/Tag.sig
    HOL/src/prekernel/Tag.sml
    HOL/tools/build.sml
    HOL/tools-poly/build.sml

Added Paths:
-----------
    HOL/src/0/Thm.sig
    HOL/src/postkernel/Definition.sig
    HOL/src/postkernel/Definition.sml
    HOL/src/postkernel/Holmakefile
    HOL/src/postkernel/SharingTables.sig
    HOL/src/postkernel/SharingTables.sml
    HOL/src/postkernel/Theory.sig
    HOL/src/postkernel/Theory.sml
    HOL/src/postkernel/TheoryPP.sig
    HOL/src/postkernel/TheoryPP.sml
    HOL/src/prekernel/FinalThm-sig.sml
    HOL/src/prekernel/Nonce.sig
    HOL/src/prekernel/Nonce.sml

Removed Paths:
-------------
    HOL/src/0/Definition-sig.sml
    HOL/src/0/Definition.sml
    HOL/src/0/Theory-sig.sml
    HOL/src/0/Theory.sml
    HOL/src/0/TheoryPP-sig.sml
    HOL/src/0/TheoryPP.sml
    HOL/src/0/Thm-sig.sml
    HOL/src/experimental-kernel/Definition.sig
    HOL/src/experimental-kernel/Definition.sml
    HOL/src/experimental-kernel/RawParse.sig
    HOL/src/experimental-kernel/RawParse.sml
    HOL/src/experimental-kernel/SharingTables.sig
    HOL/src/experimental-kernel/SharingTables.sml
    HOL/src/experimental-kernel/Theory.sig
    HOL/src/experimental-kernel/Theory.sml
    HOL/src/experimental-kernel/TheoryPP.sig
    HOL/src/experimental-kernel/TheoryPP.sml

Modified: HOL/src/0/CoreKernel-sig.sml
===================================================================
--- HOL/src/0/CoreKernel-sig.sml	2010-12-15 12:03:03 UTC (rev 8801)
+++ HOL/src/0/CoreKernel-sig.sml	2010-12-16 03:54:31 UTC (rev 8802)
@@ -3,19 +3,10 @@
   structure Type : FinalType
   structure Term : FinalTerm        where type hol_type = Type.hol_type
 
-  structure Thm  : Thm              where type hol_type = Type.hol_type
+  structure Thm  : FinalThm         where type hol_type = Type.hol_type
                                       and type term     = Term.term
                                       and type tag      = Tag.tag
 
-  structure Theory : Theory         where type hol_type = Type.hol_type
-                                      and type term     = Term.term
-                                      and type thm      = Thm.thm
-
-  structure TheoryPP : TheoryPP     where type hol_type = Type.hol_type
-                                      and type thm      = Thm.thm
-
   structure Net : Net               where type term = Term.term
 
-  structure Definition : Definition where type term = Term.term
-                                      and type thm  = Thm.thm
 end;

Deleted: HOL/src/0/Definition-sig.sml
===================================================================
--- HOL/src/0/Definition-sig.sml	2010-12-15 12:03:03 UTC (rev 8801)
+++ HOL/src/0/Definition-sig.sml	2010-12-16 03:54:31 UTC (rev 8802)
@@ -1,15 +0,0 @@
-signature Definition =
-sig
-  type term
-  type thm
-
-  val new_type_definition    : string * thm -> thm
-  val new_definition         : string * term -> thm
-  val new_specification      : string * string list * thm -> thm
-
-  val new_definition_hook    : ((term -> term list * term) *
-                                (term list * thm -> thm)) ref
-  val new_specification_hook : (string list -> unit) ref
-
-end
-

Deleted: HOL/src/0/Definition.sml
===================================================================
--- HOL/src/0/Definition.sml	2010-12-15 12:03:03 UTC (rev 8801)
+++ HOL/src/0/Definition.sml	2010-12-16 03:54:31 UTC (rev 8802)
@@ -1,175 +0,0 @@
-(* ===================================================================== *)
-(* FILE          : Definition.sml                                        *)
-(* DESCRIPTION   : Principles of type definition, constant specification *)
-(*                 and constant definition. Almost the same as in hol88, *)
-(*                 except that parsing status is not dealt with by the   *)
-(*                 functions in this module (at this stage, the parser   *)
-(*                 hasn't been compiled yet). A further difference is    *)
-(*                 the principle of constant definition is not derived   *)
-(*                 from constant specification, as in hol88. The         *)
-(*                 principle of definition has also been changed to be   *)
-(*                 simpler than that of hol88.                           *)
-(*                                                                       *)
-(* AUTHOR        : (c) Mike Gordon, University of Cambridge              *)
-(* TRANSLATOR    : Konrad Slind, University of Calgary                   *)
-(* DATE          : September 11, 1991  -- translated                     *)
-(* DATE          : October 1, 2000     -- union of previous 3 modules    *)
-(* ===================================================================== *)
-
-structure Definition : RawDefinition =
-struct
-
-open Feedback Lib KernelTypes Type Term
-
-infixr --> |->;
-
-val ERR       = mk_HOL_ERR "Definition";
-val TYDEF_ERR = ERR "new_type_definition"
-val DEF_ERR   = ERR "new_definition"
-val SPEC_ERR  = ERR "new_specification";
-
-val TYDEF_FORM_ERR = TYDEF_ERR "expected a theorem of the form \"?x. P x\"";
-val DEF_FORM_ERR   = DEF_ERR   "expected a term of the form \"v = M\"";
-
-val current_theory = Theory.current_theory;
-
-
-(*---------------------------------------------------------------------------
-      Misc. utilities. There are some local definitions of syntax
-      operations, since we delay defining all the basic formula
-      operations until after boolTheory is built.
- ---------------------------------------------------------------------------*)
-
-fun dest_atom tm = (dest_var tm handle HOL_ERR _ => dest_const tm)
-
-fun mk_exists (absrec as (Bvar,_)) =
-  mk_comb(mk_thy_const{Name="?",Thy="bool", Ty= (type_of Bvar-->bool)-->bool},
-          mk_abs absrec)
-
-fun dest_exists M =
- let val (Rator,Rand) = with_exn dest_comb M (TYDEF_ERR"dest_exists")
- in case total dest_thy_const Rator
-     of SOME{Name="?",Thy="bool",...} => dest_abs Rand
-      | otherwise => raise TYDEF_ERR"dest_exists"
- end
-
-fun nstrip_exists 0 t = ([],t)
-  | nstrip_exists n t =
-     let val (Bvar, Body) = dest_exists t
-         val (l,t'') = nstrip_exists (n-1) Body
-     in (Bvar::l, t'')
-     end;
-
-fun mk_eq (lhs,rhs) =
- let val ty = type_of lhs
-     val eq = mk_thy_const{Name="=",Thy="min",Ty=ty-->ty-->bool}
- in list_mk_comb(eq,[lhs,rhs])
- end;
-
-fun dest_eq M =
-  let val (Rator,r) = dest_comb M
-      val (eq,l) = dest_comb Rator
-  in case dest_thy_const eq
-      of {Name="=",Thy="min",...} => (l,r)
-       | _ => raise ERR "dest_eq" "not an equality"
-  end;
-
-fun check_null_hyp th f =
-  if null(Thm.hyp th) then ()
-  else raise f "theorem must have no assumptions";
-
-fun check_free_vars tm f =
-  case free_vars tm
-   of [] => ()
-    | V  => raise f (String.concat
-            ("Free variables in rhs of definition: "
-             :: commafy (map (Lib.quote o fst o dest_var) V)));
-
-fun check_tyvars body_tyvars ty f =
- case Lib.set_diff body_tyvars (type_vars ty)
-  of [] => ()
-   | extras =>
-      raise f (String.concat
-         ("Unbound type variable(s) in definition: "
-           :: commafy (map (Lib.quote o dest_vartype) extras)));
-
-fun bind s ty =
-  (Theory.new_constant (s,ty);
-   mk_thy_const {Name=s,Ty=ty,Thy=current_theory()}
-  );
-
-fun mk_def (w as TERM _, tm)    = (w, Thm.mk_defn_thm (Tag.empty_tag, tm))
-  | mk_def (w as THEOREM th,tm) = (w, Thm.mk_defn_thm (Thm.tag th, tm))
-
-val new_definition_hook = ref
-    ((fn tm => ([]:term list, tm:term)),
-     (fn (V:term list,th:thm) =>
-       if null V then th
-       else raise ERR "new_definition" "bare post-processing phase"));
-
-val (new_specification_hook:(string list -> unit) ref) = ref
- (fn _ => raise ERR "new_specification"
-            "introduced constants have not been added to the grammar")
-
-(*---------------------------------------------------------------------------*)
-(*                DEFINITION PRINCIPLES                                      *)
-(*---------------------------------------------------------------------------*)
-
-fun new_type_definition (name,thm) =
- let val (_,Body)  = with_exn dest_exists (Thm.concl thm) TYDEF_FORM_ERR
-     val P         = with_exn rator Body TYDEF_FORM_ERR
-     val Pty       = type_of P
-     val (dom,rng) = with_exn dom_rng Pty TYDEF_FORM_ERR
-     val tyvars    = Listsort.sort Type.compare (type_vars_in_term P)
-     val checked   = check_null_hyp thm TYDEF_ERR
-     val checked   = assert_exn null (free_vars P)
-                       (TYDEF_ERR "subset predicate must be a closed term")
-     val checked   = assert_exn (op=) (rng,bool)
-                      (TYDEF_ERR "subset predicate has the wrong type")
-     val   _       = Theory.new_type(name, List.length tyvars)
-     val newty     = mk_thy_type{Tyop=name,Thy=current_theory(),Args=tyvars}
-     val repty     = newty --> dom
-     val rep       = mk_primed_var("rep", repty)
-     val TYDEF     = mk_thy_const{Name="TYPE_DEFINITION", Thy="bool",
-                                    Ty = Pty --> (repty-->bool)}
-     val (wit,def) = mk_def (THEOREM thm,
-                        mk_exists(rep, list_mk_comb(TYDEF,[P,rep])))
- in
-   Theory.store_type_definition (name^"_TY_DEF", name, wit, def)
- end
- handle e => raise (wrap_exn "Definition" "new_type_definition" e);
-
-
-fun new_definition(name,M) =
- let val (dest,post) = !new_definition_hook
-     val (V,eq)      = dest M
-     val (lhs,rhs)   = with_exn dest_eq eq DEF_FORM_ERR
-     val (Name,Ty)   = with_exn dest_atom lhs DEF_FORM_ERR
-     val checked     = check_free_vars rhs DEF_ERR
-     val checked     = check_tyvars (type_vars_in_term rhs) Ty DEF_ERR
-     val (wit,def)   = mk_def(TERM rhs, mk_eq(bind Name Ty, rhs))
- in
-   Theory.store_definition (name, [Name], wit, post(V,def))
- end
- handle e => raise (wrap_exn "Definition" "new_definition" e);
-
-
-fun new_specification (name, cnames, th) =
- let val checked   = check_null_hyp th SPEC_ERR
-     val checked   = check_free_vars (Thm.concl th) SPEC_ERR
-     val checked   = assert_exn (op=) (length(mk_set cnames),length cnames)
-                     (SPEC_ERR "duplicate constant names in specification")
-     val (V,body)  = with_exn (nstrip_exists (length cnames)) (Thm.concl th)
-                     (SPEC_ERR "too few existentially quantified variables")
-     fun vOK V v   = check_tyvars V (type_of v) SPEC_ERR
-     val checked   = List.app (vOK (type_vars_in_term body)) V
-     fun addc v s  = v |-> bind s (snd(dest_var v))
-     val (wit,def) = mk_def (THEOREM th, subst (map2 addc V cnames) body)
-     val final     =  Theory.store_definition (name, cnames, wit, def)
- in
-    !new_specification_hook cnames   (* tell parser about the new names *)
-  ; final
- end
- handle e => raise (wrap_exn "Definition" "new_specification" e);
-
-end (* Definition *)

Modified: HOL/src/0/Holmakefile
===================================================================
--- HOL/src/0/Holmakefile	2010-12-15 12:03:03 UTC (rev 8801)
+++ HOL/src/0/Holmakefile	2010-12-16 03:54:31 UTC (rev 8802)
@@ -1,61 +1,48 @@
 OPTIONS = NO_OVERLAY
+
 FTAG_UI = $(protect $(SIGOBJ)/FinalTag-sig.ui)
+FTAG_UID = $(dprot $(SIGOBJ)/FinalTag-sig.ui)
+
 FTYPE_UI = $(protect $(SIGOBJ)/FinalType-sig.ui)
-FTERM_UI = $(protect $(SIGOBJ)/FinalTerm-sig.ui)
-FTHEORY_UI = $(protect $(SIGOBJ)/FinalTheory-sig.ui)
+FTYPE_UID = $(dprot $(SIGOBJ)/FinalType-sig.ui)
 
-FTAG_UID = $(dprot $(SIGOBJ)/FinalTag-sig.ui)
+FTERM_UI = $(protect $(SIGOBJ)/FinalTerm-sig.ui)
 FTERM_UID = $(dprot $(SIGOBJ)/FinalTerm-sig.ui)
-FTHEORY_UID = $(dprot $(SIGOBJ)/FinalTheory-sig.ui)
+
+FTHM_UI = $(protect $(SIGOBJ)/FinalThm-sig.ui)
+FTHM_UID = $(dprot $(SIGOBJ)/FinalThm-sig.ui)
+
 TAG_UID = $(dprot $(SIGOBJ)/Tag.ui)
 LIB_UID = $(dprot $(SIGOBJ)/Lib.ui)
 PORTABLE_UID = $(dprot $(SIGOBJ)/Portable.ui)
 COUNT_UID = $(dprot $(SIGOBJ)/Count.ui)
 HOLSET_UID = $(dprot $(SIGOBJ)/HOLset.ui)
 
-Raw-sig.uo: Raw-sig.sml KernelTypes.uo $(LIB_UID) $(FTHEORY_UID) TheoryPP-sig.ui
-	HOLMOSMLC -c -toplevel $(FTHEORY_UI) TheoryPP-sig.ui Raw-sig.sml
+Raw-sig.uo: Raw-sig.sml KernelTypes.uo $(LIB_UID) $(FTHEORY_UID)
+	$(HOLMOSMLC) -c -toplevel $(FTHEORY_UI) Raw-sig.sml
 
-Thm.uo: Thm.sml Term.uo $(TAG_UID) Raw-sig.uo $(COUNT_UID) $(HOLSET_UID)
-	$(HOLMOSMLC) -c -toplevel Raw-sig.ui Term.ui Type.ui Thm.sml
+Term.ui: Term.sig $(FTERM_UID) KernelTypes.ui
+	$(HOLMOSMLC) -c $(FTERM_UI) $<
 
-TheoryPP.uo: TheoryPP.sml Thm.uo
-	HOLMOSMLC -c -toplevel Raw-sig.ui Type.ui Term.ui Thm.ui TheoryPP.sml
+Type.ui: Type.sig $(FTYPE_UID) KernelTypes.ui
+	$(HOLMOSMLC) -c $(FTYPE_UI) $<
 
-Theory.uo: Theory.sml TheoryPP.uo $(dprot $(SIGOBJ)/Systeml.ui) $(dprot $(SIGOBJ)/UniversalType.uo)
-	HOLMOSMLC -c -toplevel Raw-sig.ui Type.ui Term.ui Thm.ui TheoryPP.ui Theory.sml
-
-Definition.uo: Definition.sml Theory.uo
-	HOLMOSMLC -c -toplevel Raw-sig.ui Type.ui Term.ui Thm.ui Theory.ui Definition.sml
-
 Net.uo: Net.sml Term.uo Raw-sig.uo
 	HOLMOSMLC -c -toplevel Raw-sig.ui Type.ui Term.ui Net.sml
 
-Thm-sig.uo: Thm-sig.sml $(LIB_UID) $(HOLSET_UID)
-	HOLMOSMLC -c -toplevel Thm-sig.sml
+Thm.ui: Thm.sig KernelTypes.ui $(FTHM_UID)
+	$(HOLMOSMLC) -c $(FTHM_UI) $<
 
-TheoryPP-sig.uo TheoryPP-sig.ui: TheoryPP-sig.sml $(PORTABLE_UID)
-	HOLMOSMLC -c -toplevel TheoryPP-sig.sml
+CoreKernel-sig.uo: CoreKernel-sig.sml Net-sig.uo Thm.uo \
+                   $(FTAG_UID) $(FTERM_UID) $(FTHM_UID) $(TAG_UID)
+	HOLMOSMLC -c -toplevel $(FTAG_UI) $(FTYPE_UI) $(FTERM_UI) $(FTHM_UI) \
+                               Net-sig.ui CoreKernel-sig.sml
 
-Theory-sig.uo: Theory-sig.sml $(PORTABLE_UID) $(FTHEORY_UID)
-	HOLMOSMLC -c -toplevel $(FTHEORY_UI) Theory-sig.sml
-
-Definition-sig.uo: Definition-sig.sml
-	$(MOSMLC) -c -toplevel Definition-sig.sml
-
-CoreKernel-sig.uo: CoreKernel-sig.sml Net-sig.uo \
-                   Thm-sig.uo $(FTAG_UID) $(FTERM_UID) Theory-sig.uo \
-                   TheoryPP-sig.uo Definition-sig.uo $(TAG_UID)
-	HOLMOSMLC -c -toplevel $(FTAG_UI) $(FTYPE_UI) $(FTERM_UI) Thm-sig.ui \
-                               Theory-sig.ui TheoryPP-sig.ui Net-sig.ui \
-                               Definition-sig.ui CoreKernel-sig.sml
-
 Net-sig.uo: Net-sig.sml
 	$(MOSMLC) -c -toplevel Net-sig.sml
 
 Overlay.uo: Overlay.sml CoreKernel-sig.uo Type.uo Term.uo $(FTAG_UID) Thm.uo \
-            TheoryPP.uo Theory.uo Definition.uo Net.uo
+            Net.uo
 	HOLMOSMLC -c -toplevel CoreKernel-sig.ui Type.ui Term.ui \
-	                       Thm.ui TheoryPP.ui Definition.ui $(FTAG_UI) \
-                               Theory.ui Net.ui  Overlay.sml
+	                       Thm.ui $(FTAG_UI) Net.ui  Overlay.sml
 

Modified: HOL/src/0/Overlay.sml
===================================================================
--- HOL/src/0/Overlay.sml	2010-12-15 12:03:03 UTC (rev 8801)
+++ HOL/src/0/Overlay.sml	2010-12-16 03:54:31 UTC (rev 8802)
@@ -9,9 +9,6 @@
   structure Term       = Term
   structure Tag        = Tag
   structure Thm        = Thm
-  structure TheoryPP   = TheoryPP
-  structure Theory     = Theory
-  structure Definition = Definition
   structure Net        = Net
 end
 

Modified: HOL/src/0/Raw-sig.sml
===================================================================
--- HOL/src/0/Raw-sig.sml	2010-12-15 12:03:03 UTC (rev 8801)
+++ HOL/src/0/Raw-sig.sml	2010-12-16 03:54:31 UTC (rev 8802)
@@ -2,105 +2,6 @@
        Internal interfaces to HOL kernel structures.
  ---------------------------------------------------------------------------*)
 
-signature RawThm =
-sig
-  type thm
-  type tag      = Tag.tag
-  type term     = KernelTypes.term
-  type hol_type = KernelTypes.hol_type
-  type 'a set   = 'a HOLset.set
-
-  val tag           : thm -> tag
-  val hyp           : thm -> term list
-  val hypset        : thm -> term set
-  val concl         : thm -> term
-  val dest_thm      : thm -> term list * term
-  val thm_frees     : thm -> term list
-  val hyp_frees     : thm -> term set
-  val hyp_tyvars    : thm -> hol_type set
-  val ASSUME        : term -> thm
-  val REFL          : term -> thm
-  val BETA_CONV     : term -> thm
-  val ABS           : term -> thm -> thm
-  val DISCH         : term -> thm -> thm
-  val MP            : thm -> thm -> thm
-  val SUBST         : (term,thm)Lib.subst -> term -> thm -> thm
-  val INST_TYPE     : (hol_type,hol_type)Lib.subst -> thm -> thm
-  val ALPHA         : term -> term -> thm
-  val MK_COMB       : thm * thm -> thm
-  val AP_TERM       : term -> thm -> thm
-  val AP_THM        : thm -> term -> thm
-  val SYM           : thm -> thm
-  val TRANS         : thm -> thm -> thm
-  val EQ_MP         : thm -> thm -> thm
-  val EQ_IMP_RULE   : thm -> thm * thm
-  val INST          : (term,term)Lib.subst -> thm -> thm
-  val SPEC          : term -> thm -> thm
-  val GEN           : term -> thm -> thm
-  val GENL          : term list -> thm -> thm
-  val EXISTS        : term * term -> thm -> thm
-  val CHOOSE        : term * thm -> thm -> thm
-  val CONJ          : thm -> thm -> thm
-  val CONJUNCT1     : thm -> thm
-  val CONJUNCT2     : thm -> thm
-  val DISJ1         : thm -> term -> thm
-  val DISJ2         : term -> thm -> thm
-  val DISJ_CASES    : thm -> thm -> thm -> thm
-  val NOT_INTRO     : thm -> thm
-  val NOT_ELIM      : thm -> thm
-  val CCONTR        : term -> thm -> thm
-  val Beta          : thm -> thm
-  val Mk_comb       : thm -> thm * thm * (thm -> thm -> thm)
-  val Mk_abs        : thm -> term * thm * (thm -> thm)
-  val Specialize    : term -> thm -> thm
-  val GEN_ABS       : term option -> term list -> thm -> thm
-  val mk_oracle_thm : string -> term list * term -> thm
-  val add_tag       : tag * thm -> thm
-  val mk_thm        : term list * term -> thm
-  val mk_axiom_thm  : string ref * term -> thm
-  val mk_defn_thm   : tag * term -> thm
-  val disk_thm      : term vector
-                       -> string list * 'a Portable.frag list list
-                                      * 'a Portable.frag list -> thm
-end;
-
-signature RawTheoryPP =
-sig
-
-  include TheoryPP where type thm = KernelTypes.thm
-                     and type hol_type = KernelTypes.hol_type
-end
-
-
-signature RawTheory =
-sig
-
-  include FinalTheory
-          where type hol_type = KernelTypes.hol_type
-            and type term     = KernelTypes.term
-            and type thm      = KernelTypes.thm
-  type witness  = KernelTypes.witness
-
-  val incorporate_consts : string -> (string*hol_type)list -> unit
-  val store_definition   : string * string list * witness * thm -> thm
-  val store_type_definition : string * string * witness * thm -> thm
-
-end
-
-
-signature RawDefinition =
-sig
-  type term = KernelTypes.term
-  type thm  = KernelTypes.thm
-
-  val new_type_definition : string * thm -> thm
-  val new_specification   : string * string list * thm -> thm
-  val new_definition      : string * term -> thm
-  val new_definition_hook : ((term -> term list * term) *
-                             (term list * thm -> thm)) ref
-  val new_specification_hook : (string list -> unit) ref
-end
-
 signature RawNet =
 sig
   type 'a net

Modified: HOL/src/0/Term.sig
===================================================================
--- HOL/src/0/Term.sig	2010-12-15 12:03:03 UTC (rev 8801)
+++ HOL/src/0/Term.sig	2010-12-16 03:54:31 UTC (rev 8802)
@@ -1,82 +1,11 @@
 signature Term =
 sig
-  type hol_type = KernelTypes.hol_type
-  type term = KernelTypes.term
-  type ('a,'b)subst = ('a,'b)Lib.subst
-  type 'a set       = 'a HOLset.set
 
+  include FinalTerm where type hol_type = KernelTypes.hol_type
+                          and type term = KernelTypes.term
+
   val termsig       : KernelTypes.holty KernelSig.symboltable
 
-  val type_of       : term -> hol_type
-  val free_vars     : term -> term list
-  val free_vars_lr  : term -> term list
-  val FVL           : term list -> term set -> term set
-  val free_in       : term -> term -> bool
-  val all_vars      : term -> term list
-  val free_varsl    : term list -> term list
-  val all_varsl     : term list -> term list
-  val type_vars_in_term : term -> hol_type list
-  val var_occurs    : term -> term -> bool
-  val genvar        : hol_type -> term
-  val genvars       : hol_type -> int -> term list
-  val variant       : term list -> term -> term
-  val prim_variant  : term list -> term -> term
-  val gen_variant   : (string -> bool) -> string -> term list -> term -> term
-  val mk_var        : string * hol_type -> term
-  val mk_primed_var : string * hol_type -> term
-  val decls         : string -> term list
-  val all_consts    : unit -> term list
-  val prim_mk_const : {Thy:string,Name:string} -> term
-  val mk_thy_const  : {Thy:string, Name:string, Ty:hol_type} -> term
-  val dest_thy_const: term -> {Thy:string, Name:string, Ty:hol_type}
-  val mk_const      : string * hol_type -> term
-  val list_mk_comb  : term * term list -> term
-  val mk_comb       : term * term -> term
-  val list_mk_binder: term option -> term list * term -> term
-  val list_mk_abs   : term list * term -> term
-  val mk_abs        : term * term -> term
-  val dest_var      : term -> string * hol_type
-  val dest_const    : term -> string * hol_type
-  val dest_comb     : term -> term * term
-  val dest_abs      : term -> term * term
-  val strip_abs     : term -> term list * term
-  val strip_binder  : term option -> term -> term list * term
-  val is_var        : term -> bool
-  val is_genvar     : term -> bool
-  val is_const      : term -> bool
-  val is_comb       : term -> bool
-  val is_abs        : term -> bool
-  val rator         : term -> term
-  val rand          : term -> term
-  val bvar          : term -> term
-  val body          : term -> term
-  val rename_bvar   : string -> term -> term
-  val is_bvar       : term -> bool
-  val same_const    : term -> term -> bool
-  val aconv         : term -> term -> bool
-  val beta_conv     : term -> term
-  val eta_conv      : term -> term
-  val subst         : (term,term) Lib.subst -> term -> term
-(*  val vsubst        : (term,term) Lib.subst -> term -> term *)
-  val inst          : (hol_type,hol_type) subst -> term -> term
-  val raw_match     : hol_type list -> term set
-                      -> term -> term
-                      -> (term,term)subst * (hol_type,hol_type)subst
-                      -> ((term,term)subst * term set) *
-                         ((hol_type,hol_type)subst * hol_type list)
-  val match_terml   : hol_type list -> term set -> term -> term
-                        -> (term,term)subst * (hol_type,hol_type)subst
-  val match_term    : term -> term -> (term,term)subst*(hol_type,hol_type)subst
-  val norm_subst    : ((term,term)subst * term set) *
-                      ((hol_type,hol_type)subst * hol_type list)
-                      -> ((term,term)subst * (hol_type,hol_type)subst)
-  val thy_consts    : string -> term list
-  val compare       : term * term -> order
-  val term_eq       : term -> term -> bool
-  val var_compare   : term * term -> order
-  val empty_tmset   : term set
-  val empty_varset  : term set
-
   val lazy_beta_conv : term -> term
   val imp            : term
   val dest_eq_ty     : term -> term * term * hol_type
@@ -86,6 +15,6 @@
   val break_abs      : term -> term
   val trav           : (term -> unit) -> term -> unit
   val pp_raw_term    : (term -> int) -> Portable.ppstream -> term -> unit
+  val is_bvar        : term -> bool
 
-  val term_size      : term -> int
 end;

Modified: HOL/src/0/Term.sml
===================================================================
--- HOL/src/0/Term.sml	2010-12-15 12:03:03 UTC (rev 8801)
+++ HOL/src/0/Term.sml	2010-12-16 03:54:31 UTC (rev 8802)
@@ -29,7 +29,18 @@
 
 
 val termsig = KernelSig.new_table()
+fun prim_delete_const kn = ignore (KernelSig.retire_name(termsig, kn))
+fun prim_new_const (k as {Thy,Name}) ty = let
+  val hty = if Type.polymorphic ty then POLY ty else GRND ty
+  val id = KernelSig.insert(termsig, k, hty)
+in
+  Const(id, hty)
+end
+fun del_segment s = KernelSig.del_segment(termsig, s)
 
+
+
+
 (*---------------------------------------------------------------------------*
  * Builtin constants. These are in every HOL signature, and it is            *
  * convenient to nail them down here.                                        *
@@ -747,7 +758,9 @@
   | dest_abs _ = raise ERR "dest_abs" "not a lambda abstraction"
 end;
 
+local
 open KernelSig
+in
 fun break_abs(Abs(_,Body)) = Body
   | break_abs(t as Clos _) = break_abs (push_clos t)
   | break_abs _ = raise ERR "break_abs" "not an abstraction";
@@ -763,6 +776,7 @@
 
 fun dest_const (Const(id,ty)) = (name_of id, to_hol_type ty)
   | dest_const _ = raise ERR "dest_const" "not a const"
+end
 
 (*---------------------------------------------------------------------------
                Derived destructors
@@ -798,6 +812,7 @@
    in look end
   fun bound_by_scope scoped M = if scoped then not (free M 0) else false
   val tymatch = Type.raw_match_type
+  open KernelSig
 in
 fun RM [] theta = theta
   | RM (((v as Fv(n,Ty)),tm,scoped)::rst) ((S1 as (tmS,Id)),tyS)
@@ -942,7 +957,7 @@
  let open Portable
      val {add_string,add_break,begin_block,end_block,...} = with_ppstream pps
      fun pp (Abs(Bvar,Body)) =
-          ( add_string "(\\";
+          ( add_string "(|";
             pp Bvar; add_string dot; add_break(1,0);
             pp Body; add_string ")" )
       | pp (Comb(Rator,Rand)) =
@@ -952,10 +967,121 @@
       | pp a      = add_string (percent^Lib.int_to_string (index a))
  in
    begin_block INCONSISTENT 0;
-   add_string "`";
    pp (norm_clos tm);
-   add_string "`";
    end_block()
  end;
 
+fun write_raw index =
+    String.translate (fn #"\n" => " " | c => str c) o
+    HOLPP.pp_to_string 75 (pp_raw_term index)
+
+(*---------------------------------------------------------------------------*
+ * Fetching theorems from disk. The following parses the "raw" term          *
+ * representation found in exported theory files.                            *
+ *---------------------------------------------------------------------------*)
+
+local
+datatype lexeme
+   = dot
+   | lamb
+   | lparen
+   | rparen
+   | ident of int
+   | bvar  of int;
+
+local val numeric = Char.contains "0123456789"
+in
+fun take_numb ss0 =
+  let val (ns, ss1) = Substring.splitl numeric ss0
+  in case Int.fromString (Substring.string ns)
+      of SOME i => (i,ss1)
+       | NONE   => raise ERR "take_numb" ""
+  end
+end;
+
+(* don't allow numbers to be split across fragments *)
+
+fun lexer ss1 =
+  case Substring.getc (Lib.deinitcommentss ss1) of
+                      (* was: (Substring.dropl Char.isSpace ss1) *)
+    NONE => NONE
+  | SOME (c,ss2) =>
+    case c of
+      #"."  => SOME(dot,   ss2)
+    | #"|" => SOME(lamb,  ss2)
+    | #"("  => SOME(lparen,ss2)
+    | #")"  => SOME(rparen,ss2)
+    | #"%"  => let val (n,ss3) = take_numb ss2 in SOME(ident n, ss3) end
+    | #"$"  => let val (n,ss3) = take_numb ss2 in SOME(bvar n,  ss3) end
+    |   _   => raise ERR "raw lexer" "bad character";
+
+fun eat_rparen ss =
+  case lexer ss
+   of SOME (rparen, ss') => ss'
+    |   _ => raise ERR "eat_rparen" "expected right parenthesis";
+
+fun eat_dot ss =
+  case lexer ss
+   of SOME (dot, ss') => ss'
+    |   _ => raise ERR "eat_dot" "expected a \".\"";
+
+in
+fun read_raw tmv = let
+  fun index i = Vector.sub(tmv, i)
+  fun parse (stk,ss) =
+      case lexer ss of
+        SOME (bvar n,  rst) => (Bv n::stk,rst)
+      | SOME (ident n, rst) => (index n::stk,rst)
+      | SOME (lparen,  rst) =>
+        (case lexer rst
+          of SOME (lamb, rst') => parse (glamb (stk,rst'))
+           |    _              => parse (parsel (parse (stk,rst))))
+      |  _ => (stk,ss)
+  and
+     parsel (stk,ss) =
+        case parse (stk,ss)
+         of (h1::h2::t, ss') => (Comb(h2,h1)::t, eat_rparen ss')
+          |   _              => raise ERR "raw.parsel" "impossible"
+  and
+     glamb(stk,ss) =
+     case lexer ss
+       of SOME (ident n, rst) =>
+            (case parse (stk, eat_dot rst)
+              of (h::t,rst1) => (Abs(index n,h)::t, eat_rparen rst1)
+               |   _         => raise ERR "glamb" "impossible")
+        | _ => raise ERR "glamb" "expected an identifier"
+in
+fn s =>
+   (case parse ([], Substring.full s)
+     of ([v], _)  => v
+      | otherwise => raise ERR "raw term parser" "parse failed")
+ | otherwise => raise ERR "raw term parser" "expected a quotation"
+end;
+end (* local *)
+
+(* ----------------------------------------------------------------------
+    Is a term up-to-date wrt the theory?
+   ---------------------------------------------------------------------- *)
+
+fun uptodate_term t = let
+  open Type
+  fun recurse tmlist =
+      case tmlist of
+        [] => true
+      | t::rest => let
+        in
+          case t of
+            Fv(_, ty) => Type.uptodate_type ty andalso recurse rest
+          | Const(info, ty) => KernelSig.uptodate_id info andalso
+                               uptodate_type (to_hol_type ty) andalso
+                               recurse rest
+          | Comb(f,x) => recurse (f::x::rest)
+          | Abs(v,bod) => recurse (v::bod::rest)
+          | Bv _ => recurse rest
+          | Clos _ => recurse (push_clos t :: rest)
+        end
+in
+  recurse [t]
+end
+
 end (* Term *)

Deleted: HOL/src/0/Theory-sig.sml
===================================================================
--- HOL/src/0/Theory-sig.sml	2010-12-15 12:03:03 UTC (rev 8801)
+++ HOL/src/0/Theory-sig.sml	2010-12-16 03:54:31 UTC (rev 8802)
@@ -1,7 +0,0 @@
-signature Theory =
-sig
-
-  include FinalTheory
-  val incorporate_consts : string -> (string*hol_type)list -> unit
-
-end

Deleted: HOL/src/0/Theory.sml
===================================================================
--- HOL/src/0/Theory.sml	2010-12-15 12:03:03 UTC (rev 8801)
+++ HOL/src/0/Theory.sml	2010-12-16 03:54:31 UTC (rev 8802)
@@ -1,1021 +0,0 @@
-(* ========================================================================= *)
-(* FILE          : Theory.sml                                                *)
-(* DESCRIPTION   : Management of logical theories.                           *)
-(*                                                                           *)
-(* AUTHOR        : Konrad Slind, University of Calgary                       *)
-(*                 (also T.U. Munich and Cambridge)                          *)
-(* DATE          : September 11, 1991                                        *)
-(* REVISION      : August 7, 1997                                            *)
-(*               : March 9, 1998                                             *)
-(*               : August 2000                                               *)
-(*                                                                           *)
-(* ========================================================================= *)
-
-(*---------------------------------------------------------------------------
-
-     Notes on the design.
-
-  We provide a single current theory segment, which can be thought of as
-  a scratchpad for building the segment that eventually gets exported.
-  The following are the important components of a segment:
-
-      - mini-signatures for the types and terms declared in the current
-        segment
-
-      - the unique id for the theory, along with its parents, which
-        should be already-loaded theory segments.
-
-      - the theory graph, used to enforce a prohibition on circular
-        dependencies among segments.
-
-      - the axioms, definitions, and theorems stored in the segment so far.
-
-      - the status of the segment: is it consistent with disk (obscure),
-        have items been deleted from the segment?
-
-  The mini-signatures are held in Type.TypeSig and Term.TermSig,
-  along with all the types and terms declared in ancestor theories.
-
-  The parents of the segment are held in the theory graph.
-
-  When a segment is exported, we dump everything in it to a text file
-  representing an ML structure.
-
-  Elements in the current segment can be deleted or overwritten, which
-  makes consistency maintenance an issue.
-
- ---------------------------------------------------------------------------*)
-
-
-structure Theory : RawTheory =
-struct
-
-open Feedback Lib KernelTypes ;
-
-type ppstream = Portable.ppstream
-type pp_type  = ppstream -> hol_type -> unit
-type pp_thm   = ppstream -> thm -> unit
-type num      = Arbnum.num
-
-infix ##;
-
-val ERR  = mk_HOL_ERR "Theory";
-val WARN = HOL_WARNING "Theory";
-
-val kernelid = "stdknl"
-
-type thy_addon = {sig_ps    : (ppstream -> unit) option,
-                  struct_ps : (ppstream -> unit) option}
-
-
-(* This reference is set in course of loading the parsing library *)
-
-val pp_thm = ref (fn _:ppstream => fn _:thm => ())
-
-(*---------------------------------------------------------------------------*
- * Unique identifiers, for securely linking a theory to its parents when     *
- * loading from disk.                                                        *
- *---------------------------------------------------------------------------*)
-
-local
-  open Arbnum
-in
-abstype thyid = UID of {name:string, sec: num, usec : num}
-with
-  fun thyid_eq x (y:thyid) = (x=y);
-  fun new_thyid s =
-      let val {sec,usec} = Portable.dest_time (Portable.timestamp())
-      in
-        UID{name=s, sec = sec, usec = usec}
-      end
-
-  fun dest_thyid (UID{name, sec, usec}) = (name,sec,usec)
-
-  val thyid_name = #1 o dest_thyid;
-
-  fun make_thyid(s,i1,i2) = UID{name=s, sec=i1,usec=i2}
-
-  fun thyid_to_string (UID{name,sec,usec}) =
-     String.concat["(",Lib.quote name,",",toString sec, ",",
-                   toString usec, ")"]
-
-  val min_thyid =
-      UID{name="min", sec = fromInt 0, usec = fromInt 0}  (* Ur-theory *)
-
-end;
-end (* local *)
-
-fun thyid_assoc x [] = raise ERR "thyid_assoc" "not found"
-  | thyid_assoc x ((a,b)::t) = if thyid_eq x a then b else thyid_assoc x t;
-
-fun thyname_assoc x [] = raise ERR "thyname_assoc" "not found"
-  | thyname_assoc x ((a,b)::t) = if x = thyid_name a then b
-                                 else thyname_assoc x t;
-
-
-(*---------------------------------------------------------------------------
-    The theory graph is quite basic: just a list of pairs (thyid,parents).
-    The "min" theory is already installed; it has no parents.
- ---------------------------------------------------------------------------*)
-
-structure Graph = struct type graph = (thyid * thyid list) list
-local val theGraph = ref [(min_thyid,[])]
-in
-   fun add (p:(thyid*thyid list)) = theGraph := (p :: !theGraph)
-   fun add_parent (n,newp) =
-     let fun same (node,_) = thyid_eq node n
-         fun addp(node,parents) = (node, op_union thyid_eq [newp] parents)
-         fun ins (a::rst) = if same a then addp a::rst else a::ins rst
-           | ins [] = raise ERR "Graph.add_parent.ins" "not found"
-     in theGraph := ins (!theGraph)
-     end
-   fun isin n = Lib.can (thyid_assoc n) (!theGraph);
-   fun parents_of n = thyid_assoc n (!theGraph);
-   fun ancestryl L =
-    let fun Anc P Q = rev_itlist
-           (fn nde => fn A => if op_mem thyid_eq nde A then A
-             else Anc (parents_of nde handle HOL_ERR _ => []) (nde::A)) P Q
-    in Anc L []
-    end;
-   fun fringe () =
-     let val all_parents = List.map #2 (!theGraph)
-         fun is_parent y = Lib.exists (Lib.op_mem thyid_eq y) all_parents
-     in List.filter (not o is_parent) (List.map #1 (!theGraph))
-     end;
-   fun first P = Lib.first P (!theGraph)
-end
-end; (* structure Graph *)
-
-
-(*---------------------------------------------------------------------------*
- * A type for distinguishing the different kinds of theorems that may be     *
- * stored in a theory.                                                       *
- *---------------------------------------------------------------------------*)
-
-datatype thmkind = Thm of thm | Axiom of string ref * thm | Defn of thm
-
-fun is_axiom (Axiom _) = true  | is_axiom _   = false;
-fun is_theorem (Thm _) = true  | is_theorem _ = false;
-fun is_defn (Defn _)   = true  | is_defn _    = false;
-
-fun drop_thmkind (Axiom(_,th)) = th
-  | drop_thmkind (Thm th)      = th
-  | drop_thmkind (Defn th)     = th;
-
-fun drop_pthmkind (s,th) = (s,drop_thmkind th);
-
-fun drop_Axkind (Axiom rth) = rth
-  | drop_Axkind    _        = raise ERR "drop_Axkind" "";
-
-
-(*---------------------------------------------------------------------------*
- * The type of HOL theory segments. Lacks fields for the type and term       *
- * signatures, which are held locally in the Type and Term structures.       *
- * Also lacks a field for the theory graph, which is held in Graph.          *
- *---------------------------------------------------------------------------*)
-
-datatype thydata = Loaded of UniversalType.t
-                 | Pending of string list
-type ThyDataMap = (string,thydata)Binarymap.dict
-                  (* map from string identifying the "type" of the data,
-                     e.g., "simp", "mono", "cong", "grammar_update",
-                     "LaTeX map", to the data itself. *)
-val empty_datamap : ThyDataMap = Binarymap.mkDict String.compare
-
-
-type segment = {thid  : thyid,                                 (* unique id  *)
-                facts : (string * thmkind) list,    (* stored ax,def,and thm *)
-                con_wrt_disk : bool,                (* consistency with disk *)
-                thydata : ThyDataMap,                   (* extra theory data *)
-                adjoin       : thy_addon list}         (*  extras for export *)
-
-
-(*---------------------------------------------------------------------------*
- *                 CREATE THE INITIAL THEORY SEGMENT.                        *
- *                                                                           *
- * The timestamp for a segment is its creation date. "con_wrt_disk" is       *
- * set to false because when a segment is created no corresponding file      *
- * gets created (the file is only created on export).                        *
- *---------------------------------------------------------------------------*)
-
-fun fresh_segment s :segment =
-   {thid=new_thyid s,  facts=[], con_wrt_disk=false, adjoin=[],
-    thydata = empty_datamap};
-
-
-local val CT = ref (fresh_segment "scratch")
-in
-  fun theCT() = !CT
-  fun makeCT seg = CT := seg
-end;
-
-val CTname = thyid_name o #thid o theCT;
-val current_theory = CTname;
-
-
-(*---------------------------------------------------------------------------*
- *                  READING FROM THE SEGMENT                                 *
- *---------------------------------------------------------------------------*)
-
-fun thy_types thyname               = Type.thy_types thyname
-fun thy_constants thyname           = Term.thy_consts thyname
-fun thy_parents thyname             = snd (Graph.first
-                                           (equal thyname o thyid_name o fst))
-fun thy_axioms (th:segment)         = filter (is_axiom o #2)   (#facts th)
-fun thy_theorems (th:segment)       = filter (is_theorem o #2) (#facts th)
-fun thy_defns (th:segment)          = filter (is_defn o #2)    (#facts th)
-fun thy_addons (th:segment)         = #adjoin th
-fun thy_con_wrt_disk n (th:segment) = #con_wrt_disk th;
-
-fun stamp thyname =
-  let val (_,sec,usec) = dest_thyid (fst (Graph.first
-                          (equal thyname o thyid_name o fst)))
-  in
-    Portable.mk_time {sec = sec, usec = usec}
-  end;
-
-local fun norm_name "-" = CTname()
-        | norm_name s = s
-      fun grab_item style name alist =
-        case Lib.assoc1 name alist
-         of SOME (_,th) => th
-          | NONE => raise ERR style
-                      ("couldn't find "^style^" named "^Lib.quote name)
-in
- val types            = thy_types o norm_name
- val constants        = thy_constants o norm_name
- fun get_parents s    = if norm_name s = CTname()
-                         then Graph.fringe() else thy_parents s
- val parents          = map thyid_name o get_parents
- val ancestry         = map thyid_name o Graph.ancestryl o get_parents
- fun current_axioms() = map drop_pthmkind (thy_axioms (theCT()))
- fun current_theorems() = map drop_pthmkind (thy_theorems (theCT()))
- fun current_definitions() = map drop_pthmkind (thy_defns (theCT()))
-end;
-
-
-(*---------------------------------------------------------------------------*
- * Is a segment empty?                                                       *
- *---------------------------------------------------------------------------*)
-
-fun empty_segment ({thid,facts, ...}:segment) =
-  let val thyname = thyid_name thid
-  in null (thy_types thyname) andalso
-     null (thy_constants thyname) andalso
-     null facts
-  end;
-
-(*---------------------------------------------------------------------------*
- *              ADDING TO THE SEGMENT                                        *
- *---------------------------------------------------------------------------*)
-
-fun add_type {name,theory,arity} thy = let
-  open Type KernelSig
-in
-  insert(typesig, {Name=name,Thy=theory}, arity);
-  thy
-end
-
-fun add_term {name,theory,htype} thy = let
-  open Term KernelSig
-in
-  insert(termsig, {Name=name,Thy=theory},
-         (if Type.polymorphic htype then POLY else GRND) htype);
-  thy
-end
-
-local fun pluck1 x L =
-        let fun get [] A = NONE
-              | get ((p as (x',_))::rst) A =
-                if x=x' then SOME (p,rst@...) else get rst (p::A)
-        in get L []
-        end
-      fun overwrite (p as (s,f)) l =
-       case pluck1 s l
-        of NONE => (p::l, false)
-         | SOME ((_,f'),l') =>
-            (case f'
-              of Thm _ => (p::l', false)
-               |  _    => (p::l', true))
-in
-fun add_fact (th as (s,_)) {thid, con_wrt_disk,facts,adjoin, thydata}
-  = let val (X,b) = overwrite th facts
-    in {facts=X, thid=thid, con_wrt_disk=con_wrt_disk, adjoin=adjoin,
-        thydata=thydata}
-    end
-end;
-
-fun new_addon a {thid, con_wrt_disk, facts, adjoin, thydata} =
-    {adjoin = a::adjoin, facts=facts, thid=thid, con_wrt_disk=con_wrt_disk,
-     thydata = thydata};
-
-local fun plucky x L =
-       let fun get [] A = NONE
-             | get ((p as (x',_))::rst) A =
-                if x=x' then SOME (rev A, p, rst) else get rst (p::A)
-       in get L []
-       end
-in
-fun set_MLbind (s1,s2) (rcd as {thid, con_wrt_disk,facts, adjoin, thydata})
- = case plucky s1 facts
-   of NONE => (WARN "set_MLbind"
-               (Lib.quote s1^" not found in current theory"); rcd)
-    | SOME (X,(_,b),Y) =>
-        {facts=X@...), adjoin=adjoin,thid=thid,
-         con_wrt_disk=con_wrt_disk, thydata = thydata}
-end;
-
-(*---------------------------------------------------------------------------
-            Deleting from the segment
- ---------------------------------------------------------------------------*)
-
-fun del_type (name,thyname) thy = let
-  open Type KernelSig
-  val knm = {Name = name, Thy = thyname}
-in
-  retire_name(typesig, knm) handle KernelSig.NotFound =>
-               WARN "del_type" (name_toString knm^" not found");
-  thy
-end
-
-(*---------------------------------------------------------------------------
-        Remove a constant from the signature.
- ---------------------------------------------------------------------------*)
-
-fun del_const (name,thyname) thy = let
-  open Term KernelSig
-  val knm = {Name=name, Thy=thyname}
-in
-  retire_name(termsig,knm) handle KernelSig.NotFound =>
-                  WARN "del_const" (name_toString knm^" not found");
-  thy
-end
-
-fun del_binding name {thid,facts,con_wrt_disk,adjoin,thydata} =
-  {facts = filter (fn (s, _) => not(s=name)) facts,
-   thid=thid, adjoin=adjoin, con_wrt_disk=con_wrt_disk,thydata=thydata};
-
-(*---------------------------------------------------------------------------
-   Clean out the segment. Note: this clears out the segment, and the
-   signatures, but does not alter the theory graph. The segment will
-   still be there, with its parents.
- ---------------------------------------------------------------------------*)
-
-fun zap_segment s {thid, con_wrt_disk, facts, adjoin, thydata} =
- let val _ = KernelSig.del_segment(Type.typesig, s)
-     val _ = KernelSig.del_segment(Term.termsig, s)
- in {adjoin=[], facts=[], con_wrt_disk=con_wrt_disk, thid=thid,
-     thydata = empty_datamap}
- end;
-
-fun set_consistency b {thid, con_wrt_disk, facts, adjoin, thydata} =
-{con_wrt_disk=b, thid=thid,facts=facts, adjoin=adjoin, thydata=thydata}
-;
-
-(*---------------------------------------------------------------------------
-       Wrappers for functions that alter the segment. Each time the
-       segment is altered, the con_wrt_disk flag is set. This is a
-       bit stewpid and I'd like to get rid of it.
- ---------------------------------------------------------------------------*)
-
-local fun inCT f arg = makeCT(set_consistency false (f arg (theCT())))
-in
-  val add_typeCT        = inCT add_type
-  val add_termCT        = inCT add_term
-  fun add_axiomCT(r,ax) = inCT add_fact (!r, Axiom(r,ax))
-  fun add_defnCT(s,def) = inCT add_fact (s,  Defn def)
-  fun add_thmCT(s,th)   = inCT add_fact (s,  Thm th)
-
-  fun delete_type n     = inCT del_type  (n,CTname())
-  fun delete_const n    = inCT del_const (n,CTname())
-  val delete_binding    = inCT del_binding
-
-  fun set_MLname s1 s2  = inCT set_MLbind (s1,s2)
-  val adjoin_to_theory  = inCT new_addon
-  val zapCT             = inCT zap_segment
-
-  fun set_ct_consistency b = makeCT(set_consistency b (theCT()))
-end;
-
-
-(*---------------------------------------------------------------------------*
- *            INSTALLING CONSTANTS IN THE CURRENT SEGMENT                    *
- *---------------------------------------------------------------------------*)
-
-fun new_type (Name,Arity) =
- (if not (Lexis.allowed_type_constant Name) andalso
-     !Globals.checking_type_names
-   then WARN "new_type" (Lib.quote Name^" is not a standard type name")
-   else ()
-  ; add_typeCT {name=Name, arity=Arity, theory = CTname()};());
-
-fun new_constant (Name,Ty) =
-  (if not (Lexis.allowed_term_constant Name) andalso
-     !Globals.checking_const_names
-   then WARN "new_constant" (Lib.quote Name^" is not a standard constant name")
-   else ()
-   ; add_termCT {name=Name, theory=CTname(), htype=Ty}; ())
-
-(*---------------------------------------------------------------------------
-     Install constants in the current theory, as part of loading a
-     previously built theory from disk.
- ---------------------------------------------------------------------------*)
-
-fun install_type(s,a,thy)   = add_typeCT {name=s, arity=a, theory=thy};
-fun install_const(s,ty,thy) = add_termCT {name=s, htype=ty, theory=thy}
-
-
-(*---------------------------------------------------------------------------
- * Is an object wellformed (current) wrt the symtab, i.e., have none of its
- * constants been re-declared after it was built? A constant is
- * up-to-date if either 1) it was not declared in the current theory (hence
- * it was declared in an ancestor theory and is thus frozen); or 2) it was
- * declared in the current theory and its witness is up-to-date.
- *
- * When a new entry is made in the theory, it is checked to see if it is
- * uptodate (or if its witnesses are). The "overwritten" bit of a segment
- * tells whether any element of the theory has been overwritten. If
- * overwritten is false, then the theory is uptodate. If we want to add
- * something to an uptodate theory, then no processing need be done.
- * Otherwise, we have to examine the item, and recursively any item it
- * depends on, to see if any constant or type constant occurring in it,
- * or any theorem it depends on, is outofdate. If so, then the item
- * will not be added to the theory.
- *
- * To clean up a theory with outofdate elements, use "scrub".
- *
- * To tell if an object is uptodate, we can't just look at it; we have
- * to recursively examine its witness(es). We can't just accept a witness
- * that seems to be uptodate, since its constants may be flagged as uptodate,
- * but some may depend on outofdate witnesses. The solution taken
- * here is to first set all constants in the segment signature to be
- * outofdate. Then a bottom-up pass is made. The "utd" flag in each
- * signature entry is used to cut off repeated recursive traversal, as in
- * dynamic programming. It holds the value "true" when the witness is
- * uptodate.
- *---------------------------------------------------------------------------*)
-
-fun up2date_id id = KernelSig.uptodate_id id
-
-fun uptodate_type ty =
-    if Type.is_vartype ty then true
-    else let val ((id,_),args) = Type.break_type ty
-         in up2date_id id
-            andalso Lib.all uptodate_type args
-         end
-
-fun uptodate_term tm =
-    let open Term
-    in if is_const tm
-       then let val (id,ty) = break_const tm
-            in up2date_id id andalso uptodate_type ty
-            end
-       else case (is_var tm, is_comb tm, is_abs tm)
-             of (true,_,_) => uptodate_type (type_of tm)
-              | (_,true,_) => uptodate_term (rator tm) andalso
-                              uptodate_term (rand tm)
-              | (_,_,true) => uptodate_term (bvar tm) andalso
-                              uptodate_term (body tm)
-              | otherwise  => raise ERR "uptodate_term" "unexpected case"
-    end
-
-fun uptodate_thm thm =
-    Lib.all uptodate_term (Thm.concl thm::Thm.hyp thm)
-    andalso
-    up2date_axioms (Tag.axioms_of (Thm.tag thm))
-
-and up2date_axioms [] = true
-  | up2date_axioms rlist =
-    let val axs = map (drop_Axkind o snd) (thy_axioms(theCT()))
-    in Lib.all (uptodate_term o Thm.concl o Lib.C Lib.assoc axs) rlist
-    end handle HOL_ERR _ => false
-
-fun scrub_sig () =
-    let
-      open Type Term KernelSig
-      fun appthis tab (knm,(kid,v)) =
-          if not (uptodate_id kid) then retire_name(tab,knm)
-          else ()
-    in
-      KernelSig.app (appthis typesig) typesig;
-      KernelSig.app (appthis termsig) termsig
-    end
-
-fun scrub_ax {thid,con_wrt_disk,facts,adjoin,thydata} =
-    let fun check (_, Thm _ ) = true
-          | check (_, Defn _) = true
-          | check (_, Axiom(_,th)) = uptodate_term (Thm.concl th)
-    in
-      {thid=thid, con_wrt_disk=con_wrt_disk, adjoin=adjoin,
-       facts=List.filter check facts, thydata=thydata}
-    end
-
-fun scrub_thms {thid,con_wrt_disk,facts,adjoin, thydata} =
-    let fun check (_, Axiom _) = true
-          | check (_, Thm th ) = uptodate_thm th
-          | check (_, Defn th) = uptodate_thm th
-    in {thid=thid, con_wrt_disk=con_wrt_disk,adjoin=adjoin,
-        facts=List.filter check facts, thydata=thydata}
-    end
-
-fun scrub () = let
-  val  _  = scrub_sig ()
-  val {thid,con_wrt_disk,facts,adjoin,thydata} =
-      scrub_thms (scrub_ax (theCT()))
-in
-  makeCT {thid=thid, con_wrt_disk=con_wrt_disk, facts=facts, adjoin=adjoin,
-          thydata = thydata}
-end
-
-fun scrubCT() = (scrub(); theCT());
-
-
-(*---------------------------------------------------------------------------*
- *   WRITING AXIOMS, DEFINITIONS, AND THEOREMS INTO THE CURRENT SEGMENT      *
- *---------------------------------------------------------------------------*)
-
-local fun check_name (fname,s) = ()
-      fun DATED_ERR f bindname = ERR f (Lib.quote bindname^" is out-of-date!")
-      val save_thm_reporting = ref 1
-      val _ = Feedback.register_trace ("Theory.save_thm_reporting",
-                                       save_thm_reporting, 2)
-      val mesg = with_flag(MESG_to_string, Lib.I) HOL_MESG
-in
-fun save_thm (name,th) =
-      (check_name ("save_thm",name)
-       ; if uptodate_thm th then add_thmCT(name,th)
-         else raise DATED_ERR "save_thm" name
-       ; if !save_thm_reporting = 0 then ()
-         else if not (!Globals.interactive) orelse !save_thm_reporting > 1
-         then
-           mesg ("Saved theorem " ^ name ^ "\n")
-         else ()
-       ; th)
-
-fun new_axiom (name,tm) =
-   let val rname = ref name
-       val axiom = Thm.mk_axiom_thm (rname,tm)
-       val  _ = check_name ("new_axiom",name)
-   in if uptodate_term tm then add_axiomCT(rname,axiom)
-      else raise DATED_ERR "new_axiom" name
-      ; axiom
-   end
-
-fun store_type_definition(name, s, witness, def) =
-  let val ()  = check_name ("store_type_definition",name)
-  in
-    if uptodate_thm def then ()
-    else raise DATED_ERR "store_type_definition" name
-    (* ; Type.TypeSig.add_witness (s,CTname(),witness) *)
-    ; add_defnCT(name,def)
-    ; def
-  end
-
-fun store_definition (name, slist, witness, def) =
-  let val ()  = check_name ("store_definition",name)
-  in
-    if uptodate_thm def then () else raise DATED_ERR "store_definition" name
-    (* ; map (fn s => Term.TermSig.add_witness (s,CTname(),witness)) slist *)
-    ; add_defnCT(name,def)
-    ; def
-  end
-
-
-end;
-
-(*---------------------------------------------------------------------------*
- * Adding a new theory into the current theory graph.                        *
- *---------------------------------------------------------------------------*)
-
-fun set_diff a b = filter (fn x => not (Lib.op_mem thyid_eq x b)) a;
-fun node_set_eq S1 S2 = null(set_diff S1 S2) andalso null(set_diff S2 S1);
-
-fun link_parents thy plist =
- let val node = make_thyid thy
-     val parents = map make_thyid plist
- in
- if Lib.all Graph.isin parents
- then if Graph.isin node
-      then if node_set_eq parents (Graph.parents_of node) then ()
-           else (HOL_MESG
-                  "link_parents: the theory has two unequal sets of parents";
-                 raise ERR "link_parents" "")
-      else Graph.add (node,parents)
- else let val baddies = Lib.filter (not o Graph.isin) parents
-          val names = map thyid_to_string baddies
-    in HOL_MESG (String.concat
-        ["link_parents: the following parents of ",
-         Lib.quote (thyid_name node),
-         "\n  should already be in the theory graph (but aren't): ",
-         String.concat (commafy names)]);
-       raise ERR "link_parents" ""
-    end
- end;
-
-fun incorporate_types thy tys =
-  let fun itype (s,a) = (install_type(s,a,thy);())
-  in List.app itype tys
-  end;
-
-fun incorporate_consts thy consts =
-  let fun iconst(s,ty) = (install_const(s,ty,thy);())
-  in List.app iconst consts
-  end;
-
-
-(* ----------------------------------------------------------------------
-    Theory data functions
-
-    In addition to the data in the current segment, we want to track the data
-    associated with all previous segments.  We do this with another reference
-    variable (yuck).
-   ---------------------------------------------------------------------- *)
-
-structure LoadableThyData =
-struct
-
-  type t = UniversalType.t
-  type DataOps = {merge : t * t -> t, read : string -> t option,
-                  write : t -> string}
-  val allthydata = ref (Binarymap.mkDict String.compare :
-                        (string, ThyDataMap) Binarymap.dict)
-  val dataops = ref (Binarymap.mkDict String.compare :
-                     (string,DataOps) Binarymap.dict)
-
-  fun ThyMap() = let
-    val {thydata,thid,...} = theCT()
-    val nm = thyid_name thid
-  in
-    Binarymap.insert(!allthydata, nm, thydata)
-  end
-
-  fun segment_data {thy,thydataty} =
-      case Binarymap.peek(ThyMap(), thy) of
-        NONE => NONE
-      | SOME dmap => let
-        in
-          case Binarymap.peek(dmap, thydataty) of
-            NONE => NONE
-          | SOME (Loaded value) => SOME value
-          | SOME (Pending _) => raise ERR "segment_data"
-                                          "Can't interpret pending loads"
-        end
-
-fun write_data_update {thydataty,data} =
-    case Binarymap.peek(!dataops, thydataty) of
-      NONE => raise ERR "write_data_update"
-                        ("No operations defined for "^thydataty)
-    | SOME {merge,read,write} => let
-        val {thydata,thid,adjoin,facts,con_wrt_disk} = theCT()
-        open Binarymap
-        fun updatemap inmap = let
-          val newdata =
-              case peek(inmap, thydataty) of
-                NONE => Loaded data
-              | SOME (Loaded t) => Loaded (merge(t, data))
-              | SOME (Pending ds) =>
-                  raise Fail "write_data_update invariant failure"
-        in
-          insert(inmap,thydataty,newdata)
-        end
-      in
-        makeCT {thydata = updatemap thydata, thid=thid, adjoin=adjoin,
-                facts=facts, con_wrt_disk = con_wrt_disk}
-      end
-
-  fun temp_encoded_update {thy, thydataty, data} = let
-    val {thydata, thid, adjoin, facts, con_wrt_disk} = theCT()
-    open Binarymap
-    fun updatemap inmap = let
-      val baddecode = ERR "temp_encoded_update"
-                          ("Bad decode for "^thydataty^" ("^data^")")
-      val newdata =
-        case (peek(inmap, thydataty), peek(!dataops,thydataty)) of
-          (NONE, NONE) => Pending [data]
-        | (NONE, SOME {read,...}) =>
-            Loaded (valOf (read data) handle Option => raise baddecode)
-        | (SOME (Loaded t), NONE) =>
-             raise Fail "temp_encoded_update invariant failure 1"
-        | (SOME (Loaded t), SOME {merge,read,...}) =>
-             Loaded (merge(t, valOf (read data)
-                              handle Option => raise baddecode))
-        | (SOME (Pending ds), NONE) => Pending (data::ds)
-        | (SOME (Pending _), SOME _) =>
-             raise Fail "temp_encoded_update invariant failure 2"
-    in
-      insert(inmap, thydataty, newdata)
-    end
-  in
-    if thy = thyid_name thid then
-      makeCT {thydata = updatemap thydata, thid=thid, facts=facts,
-              adjoin=adjoin, con_wrt_disk = con_wrt_disk}
-    else let
-        val newsubmap =
-          case peek (!allthydata, thy) of
-            NONE => updatemap empty_datamap
-          | SOME dm => updatemap dm
-      in
-        allthydata := insert(!allthydata, thy, newsubmap)
-      end
-  end
-
-  fun update_pending (m,r) thydataty = let
-    open Binarymap
-    fun update1 inmap =
-        case peek(inmap, thydataty) of
-          NONE => inmap
-        | SOME (Loaded t) => raise Fail "update_pending invariant failure 1"
-        | SOME (Pending []) => raise Fail "update_pending invariant failure 2"
-        | SOME (Pending (ds as (_ :: _))) => let
-            fun foldthis (d,acc) = m(acc, valOf (r d))
-            val ds' = List.rev ds
-          in
-            insert(inmap,thydataty,
-                   Loaded (List.foldl foldthis (valOf (r (hd ds'))) (tl ds')))
-          end
-    fun foldthis (k,v,acc) = insert(acc,k,update1 v)
-    val _ = allthydata := Binarymap.foldl foldthis
-                                          (Binarymap.mkDict String.compare)
-                                          (!allthydata)
-    val {thid,facts,adjoin,thydata,con_wrt_disk} = theCT()
-  in
-    makeCT {thid=thid,facts=facts,adjoin=adjoin,thydata = update1 thydata,
-            con_wrt_disk = con_wrt_disk}
-  end
-
-  fun 'a new {thydataty, merge, read, write} = let
-    val (mk : 'a -> t, dest) = UniversalType.embed ()
-    fun vdest t = valOf (dest t)
-    fun merge' (t1, t2) = mk(merge(vdest t1, vdest t2))
-    fun read' s = Option.map mk (read s)
-    fun write' t = write (vdest t)
-  in
-    dataops := Binarymap.insert(!dataops,
-                                thydataty,
-                                {merge=merge', read=read', write=write'});
-    update_pending (merge',read') thydataty;
-    (mk,dest)
-  end
-
-
-end (* struct *)
-
-
-(* ----------------------------------------------------------------------
-    "on load" stuff
-   ---------------------------------------------------------------------- *)
-
-val onloadfns = ref ([] : (string -> unit) list)
-fun register_onload f = (onloadfns := !onloadfns @ [f])
-
-fun load_complete thyname = List.app (fn f => f thyname) (!onloadfns)
-
-
-(*---------------------------------------------------------------------------*
- *         PRINTING THEORIES OUT AS ML STRUCTURES AND SIGNATURES.            *
- *---------------------------------------------------------------------------*)
-
-fun theory_out f width {name,style} ostrm =
- let val ppstrm = Portable.mk_ppstream
-                    {consumer = Portable.outputc ostrm,
-                     linewidth=width, flush = fn () => Portable.flush_out ostrm}
- in f ppstrm handle e => (Portable.close_out ostrm; raise e);
-    Portable.flush_ppstream ppstrm;
-    Portable.close_out ostrm
- end;
-
-fun unkind facts =
-  List.foldl (fn ((s,Axiom (_,th)),(A,D,T)) => ((s,th)::A,D,T)
-               | ((s,Defn th),(A,D,T))     => (A,(s,th)::D,T)
-               | ((s,Thm th),(A,D,T))     => (A,D,(s,th)::T)) ([],[],[]) facts;
-
-val utd_types  = List.filter uptodate_type;
-val utd_consts = List.filter uptodate_term;
-val utd_thms   = List.filter uptodate_thm;
-
-(* automatically reverses the list, which is what is needed. *)
-
-fun unadjzip [] A = A
-  | unadjzip ({sig_ps,struct_ps}::t) (l1,l2) =
-       unadjzip t (sig_ps::l1, struct_ps::l2)
-
-
-(*---------------------------------------------------------------------------
-    We always export the theory, except if it is the initial theory (named
-    "scratch") and the initial theory is empty. If the initial theory is
-    *not* empty, i.e., the user made some definitions, or stored some
-    theorems or whatnot, then the initial theory will be exported.
- ----------------------------------------------------------------------------*)
-
-fun total_cpu {usr,sys} = Time.+(usr,sys)
-val new_theory_time = ref (total_cpu (Timer.checkCPUTimer Globals.hol_clock))
-
-val report_times = ref true
-
-val _ = Feedback.register_btrace ("report_thy_times", report_times)
-
-local
-  val mesg = Lib.with_flag(Feedback.MESG_to_string, Lib.I) HOL_MESG
-  fun maybe_log_time_to_disk thyname timestr = let
-    open FileSys
-    fun concatl pl = List.foldl (fn (p2,p1) => Path.concat(p1,p2))
-                                (hd pl) (tl pl)
-    val filename_opt = let
-      val build = Systeml.build_log_file
-      val currentdir = Systeml.make_log_file
-    in
-      List.find (fn s => access(s, [A_WRITE])) [build, currentdir]
-    end
-  in
-    case filename_opt of
-      SOME s => let
-        val fs = TextIO.openAppend s
-      in
-        TextIO.output(fs, thyname ^ " " ^ timestr ^ "\n");
-        TextIO.closeOut fs
-      end
-    | NONE => ()
-  end
-in
-fun export_theory () =
- let val {thid,con_wrt_disk,facts,adjoin,thydata} = scrubCT()
- in
- if con_wrt_disk
- then HOL_MESG ("\nTheory "^Lib.quote(thyid_name thid)^" already \
-                 \consistent with disk, hence not exported.\n")
- else
- let val concat = String.concat
-     val thyname = thyid_name thid
-     val name = CTname()^"Theory"
-     val (A,D,T) = unkind facts
-     val (sig_ps, struct_ps) = unadjzip adjoin ([],[])
-     val sigthry = {name = thyname,
-                    parents = map thyid_name (Graph.fringe()),
-                    axioms = A,
-                    definitions = D,
-                    theorems = T,
-                    sig_ps = sig_ps}
-   fun mungethydata dmap = let
-     fun foldthis (k,v,acc) =
-         case v of
-           Loaded t => let
-             val {write,...} = Binarymap.find (!LoadableThyData.dataops, k)
-           in
-             Binarymap.insert(acc,k,write t)
-           end
-         | _ => acc
-   in
-     Binarymap.foldl foldthis (Binarymap.mkDict String.compare) dmap
-   end
-
-     val structthry =
-         {theory = dest_thyid thid,
-          parents = map dest_thyid (Graph.fringe()),
-          types = thy_types thyname,
-          constants = Lib.mapfilter Term.dest_const (thy_constants thyname),
-          axioms = A,
-          definitions = D,
-          theorems = T,
-          struct_ps = struct_ps,
-          thydata = mungethydata thydata}
- in
-   case filter (not o Lexis.ok_sml_identifier) (map fst (A@...))
-    of [] =>
-       (let val ostrm1 = Portable.open_out(concat["./",name,".sig"])
-            val ostrm2 = Portable.open_out(concat["./",name,".sml"])
-            val time_now = total_cpu (Timer.checkCPUTimer Globals.hol_clock)
-            val time_since = Time.-(time_now, !new_theory_time)
-            val tstr = Time.toString time_since
-        in
-          mesg ("Exporting theory "^Lib.quote thyname^" ... ");
-          theory_out (TheoryPP.pp_struct structthry) 75
-                     {name=name, style="structure"} ostrm2;
-          theory_out (TheoryPP.pp_sig (!pp_thm) sigthry) 85
-                     {name=name, style="signature"} ostrm1;
-          set_ct_consistency true;
-          mesg "done.\n";
-          if !report_times then
-            (mesg ("Theory "^Lib.quote thyname^" took "^ tstr ^"s to build\n");
-             maybe_log_time_to_disk thyname tstr)
-          else ()
-
-        end
-        handle e => (Lib.say "\nFailure while writing theory!\n"; raise e))
-
-     | badnames => (HOL_MESG
-          (String.concat
-           ["\nThe following ML binding names in the theory to be exported:\n",
-            String.concat (Lib.commafy (map Lib.quote badnames)),
-            "\n are not acceptable ML identifiers.\n",
-            "   Use `set_MLname <bad> <good>' to change each name."]);
-          raise ERR "export_theory" "bad binding names")
- end
-end end;
-
-(*---------------------------------------------------------------------------*
- *    Allocate a new theory segment over an existing one. After              *
- *    that, initialize any registered packages. A package registers          *
- *    with a call to "after_new_theory".                                     *
- *---------------------------------------------------------------------------*)
-
-local val initializers = ref [] : (string * string -> unit) list ref
-in
-fun after_new_theory f = (initializers := f :: !initializers)
-fun initialize oldname =
-  let val ct = current_theory()
-      fun rev_app [] = ()
-        | rev_app (f::rst) =
-            (rev_app rst;
-             f (oldname, ct) handle e =>
-                let val errstr =
-                   case e
-                    of HOL_ERR r => !ERR_to_string r
-                     | otherwise => General.exnMessage e
-                in
-                  WARN "new_theory.initialize"
-                        ("an initializer failed with message: "
-                         ^errstr^"\n ... continuing anyway. \n")
-                end)
-  in rev_app (!initializers)
-  end
-end;
-
-fun new_theory str =
-  if not(Lexis.ok_identifier str)
-  then raise ERR "new_theory"
-         ("proposed theory name "^Lib.quote str^" is not an identifier")
-  else
-  let val thy as {thid, con_wrt_disk,...} = theCT()
-      val thyname = thyid_name thid
-      fun mk_thy () = (HOL_MESG ("Created theory "^Lib.quote str);
-                        makeCT(fresh_segment str); initialize thyname)
-      val _ =
-          new_theory_time := total_cpu (Timer.checkCPUTimer Globals.hol_clock)
-  in
-   if str=thyname
-      then (HOL_MESG("Restarting theory "^Lib.quote str);
-            zapCT str; initialize thyname)
-   else
-   if mem str (ancestry thyname)
-      then raise ERR"new_theory" ("theory: "^Lib.quote str^" already exists.")
-   else
-   if thyname="scratch" andalso empty_segment thy
-      then mk_thy()
-   else
-    (if con_wrt_disk then () else export_theory ();
-     Graph.add (thid, Graph.fringe()); mk_thy ()
-    )
-  end;
-
-
-(*---------------------------------------------------------------------------*)
-(* Function f tries to extend current theory. If that fails, or if predicate *)
-(* is_ok (expected to be total) returns false, then revert to previous state *)
-(* and return FAIL. Otherwise return PASS y, where y is what (if anything)   *)
-(* f(x) returned.                                                            *)
-(*                                                                           *)
-(* We do not (yet) track changes to the state used by adjoin_to_theory or    *)
-(* after_new_theory.                                                         *)
-(*---------------------------------------------------------------------------*)
-
-(* Overly complex definition commented out
-fun attempt_theory_extension is_ok f x =
-  let infix ?>
-      open Term
-      val tnames1 = map fst (types"-")
-      val cnames1 = map (fst o dest_const) (constants"-")
-      fun revert _ =
-        let val tnames2 = map fst (types"-")
-            val cnames2 = map (fst o dest_const) (constants"-")
-            val new_tnames = Lib.set_diff tnames2 tnames1
-            val new_cnames = Lib.set_diff cnames2 cnames1
-        in map delete_type new_tnames;
-           map delete_const new_cnames;
-           scrub()
-        end
-  in
-    case (verdict f revert x ?> verdict (assert is_ok) revert)
-     of PASS y => PASS y
-      | FAIL((),e) => FAIL (wrap_exn "Theory" "attempt_theory_extension" e)
-  end;
-*)
-
-fun try_theory_extension f x =
-  let infix ?>
-      open Term
-      val tnames1 = map fst (types"-")
-      val cnames1 = map (fst o dest_const) (constants"-")
-      fun revert _ =
-        let val tnames2 = map fst (types"-")
-            val cnames2 = map (fst o dest_const) (constants"-")
-            val new_tnames = Lib.set_diff tnames2 tnames1
-            val new_cnames = Lib.set_diff cnames2 cnames1
-        in map delete_type new_tnames;
-           map delete_const new_cnames;
-           scrub()
-        end
-  in
-    f x handle e => (revert(); raise e)
-  end;
-
-end (* Theory *)

Deleted: HOL/src/0/TheoryPP-sig.sml
===================================================================
--- HOL/src/0/TheoryPP-sig.sml	2010-12-15 12:03:03 UTC (rev 8801)
+++ HOL/src/0/TheoryPP-sig.sml	2010-12-16 03:54:31 UTC (rev 8802)
@@ -1,41 +0,0 @@
-(*---------------------------------------------------------------------------*
- * MODULE      : TheoryPP                                                    *
- * DESCRIPTION : HOL theories represented by SML structures.                 *
- * AUTHOR      : Konrad Slind                                                *
- * DATE        : 1998                                                        *
- *---------------------------------------------------------------------------*)
-
-signature TheoryPP =
-sig
- type thm
- type hol_type
- type ppstream = Portable.ppstream
- type num = Arbnum.num
-
- val pp_type : string -> string -> ppstream -> hol_type -> unit
-
- val pp_sig
-   : (ppstream -> thm -> unit)
-     -> {name        : string,
-         parents     : string list,
-         axioms      : (string * thm) list,
-         definitions : (string * thm) list,
-         theorems    : (string * thm) list,
-         sig_ps      : (ppstream -> unit) option list}
-     -> ppstream
-     -> unit
-
- val pp_struct
-   : {theory      : string*num*num,
-      parents     : (string*num*num) list,
-      types       : (string*int) list,
-      constants   : (string*hol_type) list,
-      axioms      : (string * thm) list,
-      definitions : (string * thm) list,
-      theorems    : (string * thm) list,
-      thydata     : (string,string)Binarymap.dict,
-      struct_ps   : (ppstream -> unit) option list}
-   -> ppstream
-   -> unit
-
-end

Deleted: HOL/src/0/TheoryPP.sml
===================================================================
--- HOL/src/0/TheoryPP.sml	2010-12-15 12:03:03 UTC (rev 8801)
+++ HOL/src/0/TheoryPP.sml	2010-12-16 03:54:31 UTC (rev 8802)
@@ -1,525 +0,0 @@
-(*---------------------------------------------------------------------------*
- *                                                                           *
- *            HOL theories interpreted by SML structures.                    *
- *                                                                           *
- *---------------------------------------------------------------------------*)
-
-structure TheoryPP : RawTheoryPP =
-struct
-
-type thm      = KernelTypes.thm;
-type term     = KernelTypes.term
-type hol_type = KernelTypes.hol_type
-type num = Arbnum.num
-
-open Feedback Lib Portable;
-
-val ERR = mk_HOL_ERR "TheoryPP";
-
-val concat = String.concat;
-val sort = Lib.sort (fn s1:string => fn s2 => s1<=s2);
-val psort = Lib.sort (fn (s1:string,_:Thm.thm) => fn (s2,_:Thm.thm) => s1<=s2);
-fun thid_sort x = Lib.sort (fn (s1:string,_,_) => fn (s2,_,_) => s1<=s2) x;
-fun thm_terms th = Thm.concl th :: Thm.hyp th;
-
-(*---------------------------------------------------------------------------*)
-(* Print a type                                                              *)
-(*---------------------------------------------------------------------------*)
-
-fun Thry s = s^"Theory";
-fun ThrySig s = Thry s
-
-fun pp_type mvartype mtype pps ty =
- let open Portable Type
-     val pp_type = pp_type mvartype mtype pps
-     val {add_string,add_break,begin_block,end_block,
-          add_newline,flush_ppstream,...} = with_ppstream pps
- in
-  if is_vartype ty
-  then case dest_vartype ty
-        of "'a" => add_string "alpha"
-         | "'b" => add_string "beta"
-         | "'c" => add_string "gamma"
-         | "'d" => add_string "delta"
-         |  s   => add_string (mvartype^quote s)
-  else
-  case dest_thy_type ty
-   of {Tyop="bool",Thy="min", Args=[]} => add_string "bool"
-    | {Tyop="ind", Thy="min", Args=[]} => add_string "ind"
-    | {Tyop="fun", Thy="min", Args=[d,r]}
-       => (add_string "(";
-           begin_block INCONSISTENT 0;
-             pp_type d;
-             add_break (1,0);
-             add_string "-->";
-             add_break (1,0);
-             pp_type r;
-           end_block ();
-           add_string ")")
-   | {Tyop,Thy,Args}
-      => let in
-           add_string mtype;
-           begin_block INCONSISTENT 0;
-           add_string (quote Tyop);
-           add_break (1,0);
-           add_string (quote Thy);
-           add_break (1,0);
-           add_string "[";
-           begin_block INCONSISTENT 0;
-           pr_list pp_type (fn () => add_string ",")
-           (fn () => add_break (1,0)) Args;
-           end_block ();
-           add_string "]";
-           end_block ()
-         end
- end
-
-fun with_parens pfn pp x =
-  let open Portable
-  in add_string pp "("; pfn pp x; add_string pp ")"
-  end
-
-val include_docs = ref true
-val _ = Feedback.register_btrace ("TheoryPP.include_docs", include_docs)
-
-fun pp_sig pp_thm info_record ppstrm = let
-  val {name,parents,axioms,definitions,theorems,sig_ps} = info_record
-  val {add_string,add_break,begin_block,end_block,
-       add_newline,flush_ppstream,...} = Portable.with_ppstream ppstrm
-  val pp_thm       = pp_thm ppstrm
-  val parents'     = sort parents
-  val axioms'      = psort axioms
-  val definitions' = psort definitions
-  val theorems'    = psort theorems
-  val thml         = axioms@...
-  fun vblock(header, ob_pr, obs) =
-    (begin_block CONSISTENT 2;
-     add_string ("(*  "^header^ "  *)");
-     add_newline();
-     pr_list ob_pr (fn () => ()) add_newline obs;
-     end_block())
-  fun pparent s = String.concat ["structure ",Thry s," : ",ThrySig s]
-  val parentstring = "Parent theory of "^Lib.quote name
-  fun pr_parent s = (begin_block CONSISTENT 0;
-                     add_string (String.concat ["[", s, "]"]);
-                     add_break(1,0);
-                     add_string parentstring; end_block())
-  fun pr_parents [] = ()
-    | pr_parents slist =
-      ( begin_block CONSISTENT 0;
-        pr_list pr_parent (fn () => ())
-                (fn () => (add_newline(); add_newline()))
-               slist;
-        end_block();
-        add_newline(); add_newline())
-
-  fun pr_thm class (s,th) =
-    (begin_block CONSISTENT 3;
-     add_string (String.concat ["[", s, "]"]);
-     add_string ("  "^class);
-     add_newline(); add_newline();
-     if null (Thm.hyp th) andalso
-        (Tag.isDisk (Thm.tag th) orelse Tag.isEmpty (Thm.tag th))
-       then pp_thm th
-       else with_flag(Globals.show_tags,true)
-             (with_flag(Globals.show_assums, true) pp_thm) th;
-     end_block())
-  fun pr_thms _ [] = ()
-    | pr_thms heading plist =
-       ( begin_block CONSISTENT 0;
-         pr_list (pr_thm heading) (K ())
-                 (fn () => (add_newline(); add_newline()))
-                 plist;
-         end_block();
-         add_newline(); add_newline())
-  fun pr_sig_ps NONE = ()  (* won't be fired because of filtering below *)
-    | pr_sig_ps (SOME pp) = (begin_block CONSISTENT 0;
-                             pp ppstrm; end_block());
-  fun pr_sig_psl [] = ()
-    | pr_sig_psl l =
-       (add_newline(); add_newline();
-        begin_block CONSISTENT 0;
-        pr_list pr_sig_ps (fn () => ())
-               (fn () => (add_newline(); add_newline())) l;
-        end_block());
-
-  fun pr_docs() =
-      if !include_docs then
-        (begin_block CONSISTENT 3;
-         add_string "(*"; add_newline();
-         pr_parents parents';
-         pr_thms "Axiom" axioms';
-         pr_thms "Definition" definitions';
-         pr_thms "Theorem" theorems';
-         end_block(); add_newline(); add_string "*)"; add_newline())
-      else ()
-  fun pthms (heading, ths) =
-    vblock(heading,
-           (fn (s,th) => (begin_block CONSISTENT 0;
-                          add_string(concat["val ",s, " : thm"]);
-                          end_block())),  ths)
-in
-  begin_block CONSISTENT 0;
-  add_string ("signature "^ThrySig name^" ="); add_newline();
-  begin_block CONSISTENT 2;
-  add_string "sig"; add_newline();
-  begin_block CONSISTENT 0;
-  add_string"type thm = Thm.thm";
-  if null axioms' then ()
-  else (add_newline(); add_newline(); pthms ("Axioms",axioms'));
-  if null definitions' then ()
-  else (add_newline(); add_newline(); pthms("Definitions", definitions'));
-  if null theorems' then ()
-  else (add_newline(); add_newline(); pthms ("Theorems", theorems'));
-  pr_sig_psl (filter (fn NONE => false | _ => true) sig_ps);
-  end_block();
-  end_block();
-  add_newline();
-  pr_docs();  (* end of if-then-else *)
-  add_string"end"; add_newline();
-  end_block();
-  flush_ppstream()
-end;
-
-(*---------------------------------------------------------------------------
- * Set up a sharing table.
- *---------------------------------------------------------------------------*)
-
-val table_size = 311
-val hash = Lib.hash table_size;
-
-val share_table = Array.array(table_size, [] :(Term.term * int)list);
-val taken = ref 0;
-
-fun reset_share_table () =
-  (taken := 0;
-   Lib.for_se 0 (table_size-1) (fn i => Array.update(share_table,i,[])));
-
-fun hash_type ty n =
-  hash(Type.dest_vartype ty) (0,n)
-  handle HOL_ERR _ =>
-     let val {Tyop,Thy,Args} = Type.dest_thy_type ty
-     in itlist hash_type Args (hash Thy (0, hash Tyop (0,n)))
-     end;
-
-fun hash_atom tm n =
-  let val (Name,Ty) = Term.dest_var tm
-  in hash_type Ty (hash Name (0,n))
-  end handle HOL_ERR _ =>
-       let val {Name,Thy,Ty} = Term.dest_thy_const tm
-       in hash_type Ty (hash Thy (0, hash Name (0,n)))
-       end;
-
-
-(*---------------------------------------------------------------------------
- * Add an atom to the atom hash table, checking to see if it is already there
- * first.
- *---------------------------------------------------------------------------*)
-
-fun add tm =
-  let val i = hash_atom tm 0
-      val els = Array.sub(share_table, i)
-      fun loop [] =
-               (Array.update(share_table, i, (tm,!taken)::els);
-                taken := !taken + 1)
-        | loop ((x,index)::rst) = if x=tm then () else loop rst
-  in
-    loop els
-  end;
-
-
-(*---------------------------------------------------------------------------*)
-(* Get the vector index of an atom.                                          *)
-(*---------------------------------------------------------------------------*)
-
-fun index tm =
-  let val i = hash_atom tm 0
-      val els = Array.sub(share_table, i)
-      fun loop [] = raise ERR "index" "not found in table"
-        | loop ((x,index)::rst) = if x=tm then index else loop rst
-  in
-    loop els
-  end;
-
-val pp_raw = Term.pp_raw_term index;
-
-local open Portable Feedback
-in
-fun check V thml =
-  let val _ = HOL_MESG "Checking consistency of sharing scheme"
-      fun chk tm =
-         if (Vector.sub(V, index tm) = tm)
-          then ()
-           else (HOL_MESG "FAILURE in sharing scheme!";
-                 raise ERR "check" "failure in sharing scheme")
-  in List.app (app (Term.trav chk) o thm_terms o snd) thml;
-     HOL_MESG "Completed successfully"
-  end
-end;
-
-
-fun share_thy check_share thms =
-  let val _ = reset_share_table()
-      val _ = List.app (app (Term.trav add) o thm_terms o snd) thms
-      val L0 = Array.foldr (op @) [] share_table
-      val L1 = Lib.sort (fn (_,i0) => fn (_,i1) => i0<=i1) L0
-      val slist = map fst L1
-      val _ = if check_share then check (Vector.fromList slist) thms else ()
-  in
-    slist
-  end;
-
-(*---------------------------------------------------------------------------
- * Need to replace a backslash by two backslashes because one of them
- * disappears when sent through "output". (Occurrences of " inside a string
- * have a similar problem.) Also need to add string quotes at each end
- * of the string.
- *---------------------------------------------------------------------------*)
-
-local val backslash = #"\\"
-      val double_quote = #"\""
-      fun needs_backslash s =
-        let fun loop i =
-             let val c = String.sub(s,i)
-             in (c = backslash) orelse (c = double_quote) orelse loop (i+1)
-             end handle Subscript => false
-        in loop 0
-        end
-      fun add_backslashes s =
-        let fun add i A = add (i+1)
-              (let val c = String.sub(s,i)
-               in if (c = backslash) orelse (c = double_quote)
-                  then  (c:: #"\\" ::A)
-                  else c::A end)
-               handle Subscript => String.implode(rev(double_quote::A))
-        in add 0 [#"\""]
-        end
-in
-fun stringify s =
-  if Lexis.ok_identifier s orelse not(needs_backslash s)
-  then Lib.quote s
-  else add_backslashes s
-end;
-
-
-(*---------------------------------------------------------------------------
- *  Print a theory as a module.
- *---------------------------------------------------------------------------*)
-
-infix >>
-fun (f1 >> f2) pps = (f1 pps ; f2 pps)
-
-fun block state brkdepth f pps = (HOLPP.begin_block pps state brkdepth ;
-                                  f pps;
-                                  HOLPP.end_block pps)
-fun add_string s pps = HOLPP.add_string pps s
-val add_newline = HOLPP.add_newline
-fun add_break ipr pps = HOLPP.add_break pps ipr
-val flush = HOLPP.flush_ppstream
-fun nothing pps = ()
-
-fun pr_thydata thyname thymap = let
-  fun keyval commap (k,v) =
-      block CONSISTENT 2 (add_string (k^" =") >> add_break(1,2) >>
-                          add_string ("\""^String.toString v^"\"" ^
-                                      (if commap then "," else "")))
-  fun one_entry (s, data) =
-      (add_string "val _ = Theory.LoadableThyData.temp_encoded_update {" >>
-       add_break(0,2) >>
-       block CONSISTENT 0
-         (keyval true ("thy", thyname) >>
-          add_break(1,0) >>
-          keyval true ("thydataty", s) >>
-          add_break(1,0) >>
-          keyval false ("data", data)) >>
-       add_break(0,0) >>
-       add_string "}" >>
-       add_newline)
-in
-  Binarymap.foldl (fn (k, data, rest) => one_entry (k,data) >> rest)
-                  nothing
-                  thymap
-end
-
-fun pp_struct info_record ppstrm =
- let open Term
-     val {theory as (name,i1,i2), parents=parents0, thydata,
-          axioms,definitions,theorems,types,constants,struct_ps} = info_record
-     val parents1 = filter (fn (s,_,_) => not ("min"=s)) parents0
-     val {add_string,add_break,begin_block,end_block, add_newline,
-          flush_ppstream,...} = Portable.with_ppstream ppstrm
-     val pp_tm = pp_raw ppstrm
-     val pp_ty = with_parens (pp_type "U" "T") ppstrm
-     val pp_tag = Tag.pp_to_disk ppstrm
-     fun pblock(header, ob_pr, obs) =
-         case obs
-         of [] => ()
-          |  _ =>
-            ( begin_block CONSISTENT 0;
-              add_string ("(*  Parents *)");
-              add_newline();
-              add_string "local open ";
-              begin_block INCONSISTENT 0;
-              pr_list ob_pr (fn () => ()) (fn () => add_break (1,0)) obs;
-              end_block();
-              add_newline(); add_string "in end;";
-              end_block())
-     fun pp_sml_list pfun L =
-       (begin_block CONSISTENT 0; add_string "[";
-         begin_block INCONSISTENT 0;
-         pr_list pfun (fn () => add_string",") (fn () => add_break(1,0)) L;
-         end_block(); add_string "]"; end_block())
-     fun pp_thid(s,i,j) =
-          (begin_block CONSISTENT 0; add_string"(";
-            add_string (stringify s); add_string",";
-            add_break(0,0);
-            add_string("Arbnum.fromString \""^Arbnum.toString i^"\"");
-            add_string","; add_break(0,0);
-            add_string("Arbnum.fromString \""^Arbnum.toString j^"\"");
-            add_string")"; end_block())
-     fun pp_ty_dec(s,i) =
-          (begin_block CONSISTENT 0; add_string"(";
-            add_string (stringify s); add_string",";
-            add_break(0,0); add_string(Lib.int_to_string i);
-            add_string")"; end_block())
-     fun pp_const_dec(s,ty) =
-          (begin_block INCONSISTENT 1; add_string"(";
-            add_string (stringify s); add_string",";
-            add_break(0,0); pp_ty ty;
-            add_string")"; end_block())
-     fun pp_incorporate theory parents types constants =
-         (begin_block CONSISTENT 0;
-          begin_block CONSISTENT 8;
-            add_string "val _ = Theory.link_parents"; add_break(1,0);
-            pp_thid theory; add_break(1,0); pp_sml_list pp_thid parents;
-            add_string ";" ;end_block(); add_newline();
-          begin_block CONSISTENT 5;
-            add_string ("val _ = Theory.incorporate_types "^stringify name);
-            add_break(1,0); pp_sml_list pp_ty_dec types;add_string ";" ;
-          end_block(); add_newline();
-          begin_block CONSISTENT 3;
-            add_string ("val _ = Theory.incorporate_consts "^stringify name);
-            add_break(1,0); pp_sml_list pp_const_dec constants;
-            add_string ";" ;
-          end_block(); add_newline();
-          end_block())
-     fun pparent (s,i,j) = Thry s
-     fun pr_var v =
-         let val (Name,Ty) = dest_var v
-         in add_string "V";
-            begin_block INCONSISTENT 0;
-            add_string(stringify Name); add_break(1,0);
-            pp_ty Ty; end_block()
-         end
-     fun pr_const c =
-         let val {Name,Thy,Ty} = dest_thy_const c
-         in add_string "C";
-            begin_block INCONSISTENT 0;
-            add_string(stringify Name); add_break(1,0);
-            add_string(stringify Thy); add_break(1,0);
-            pp_ty Ty; end_block()
-         end
-     fun pr_atom a =
-           (begin_block INCONSISTENT 2;
-            if is_var a then pr_var a else pr_const a;
-            end_block())
-        handle HOL_ERR _ => raise ERR"pp_struct.pr_atom" "not atomic"
-     fun pr_bind (s,th) =
-      let val (tg,asl,w) = (Thm.tag th, Thm.hyp th, Thm.concl th)
-      in
-         begin_block INCONSISTENT 2;
-         add_string"val"; add_break(1,0); add_string ("op "^s);
-         add_break (1,0);
-         add_string "="; add_break (1,0);
-         add_string"DT("; begin_block INCONSISTENT 0;
-                        pp_tag tg; add_string","; add_break(1,0);
-                        pp_sml_list pp_tm asl; add_string","; add_break(1,0);
-                        pp_tm w; end_block();
-         add_string")";
-         end_block()
-      end
-     val thml = axioms@...
-     val slist = share_thy false thml
-
-     fun bind_theorems () = if null thml then ()
-      else (
-        begin_block CONSISTENT 0;
-        add_string "local"; add_break(1,0);
-        begin_block CONSISTENT 0;
-        add_string "val share_table = Vector.fromList"; add_break(1,0);
-        pp_sml_list pr_atom slist; add_newline();
-        add_string"val DT = Thm.disk_thm share_table";
-        end_block();
-        add_newline();
-        add_string"in"; add_newline();
-        begin_block CONSISTENT 0;
-        pr_list pr_bind (fn () => ()) add_newline thml;
-        end_block();
-        add_newline();
-        add_string"end"; end_block())
-
-     fun pr_dbtriple (class,th) =
-        (begin_block CONSISTENT 1;
-         add_string"("; add_string (stringify th); add_string",";
-         add_break (0,0); add_string th; add_string","; add_break(0,0);
-         add_string class; add_string ")"; end_block())
-
-     fun dblist () =
-        let val axl  = map (fn (s,_) => ("DB.Axm",s)) axioms
-            val defl = map (fn (s,_) => ("DB.Def",s)) definitions
-            val thml = map (fn (s,_) => ("DB.Thm",s)) theorems
-        in
-           begin_block INCONSISTENT 0;
-           add_string "val _ = DB.bindl"; add_break(1,0);
-           add_string (stringify name); add_break(1,0);
-           pp_sml_list pr_dbtriple (axl@...);
-           add_newline();
-           end_block()
-        end
-     fun pr_ps NONE = ()
-       | pr_ps (SOME pp) = (begin_block CONSISTENT 0; pp ppstrm; end_block());
-     fun pr_psl l =
-          (begin_block CONSISTENT 0;
-            pr_list pr_ps (fn () => ())
-              (fn () => (add_newline(); add_newline())) l;
-            end_block());
-
-   in
-      begin_block CONSISTENT 0;
-      add_string (String.concat
-           ["structure ",Thry name," :> ", ThrySig name," ="]);
-      add_newline();
-      begin_block CONSISTENT 2;
-      add_string "struct"; add_newline();
-      begin_block CONSISTENT 0;
-      add_string ("val _ = if !Globals.print_thy_loads then print \"Loading "^
-                  Thry name^" ... \" else ()"); add_newline();
-      add_string "open Type Term Thm"; add_newline();
-      add_string "infixr -->"; add_newline();
-      add_string"fun C s t ty = mk_thy_const{Name=s,Thy=t,Ty=ty}";
-      add_newline();
-      add_string"fun T s t A = mk_thy_type{Tyop=s, Thy=t,Args=A}";
-      add_newline();
-      add_string"fun V s q = mk_var(s,q)";     add_newline();
-      add_string"val U     = mk_vartype";              add_newline();
-   (*   add_string("val _ = print \"Loading theory: "^Thry name^"\\n\""); *)
-      add_newline();
-      pblock ("Parents", add_string o pparent,
-              thid_sort parents1);
-      add_newline();
-      pp_incorporate theory parents0 types constants; add_newline();
-      bind_theorems (); add_newline();
-      dblist(); add_newline();
-      pr_psl struct_ps;
-      pr_thydata name thydata ppstrm;
-      end_block();
-      end_block();
-      add_string "val _ = if !Globals.print_thy_loads then print \"done\\n\" else ()"; add_newline();
-      add_string ("val _ = Theory.load_complete \""^String.toString name^ "\"");
-      add_newline();
-      add_break(0,0); add_string"end"; add_newline();
-      end_block();
-      flush_ppstream()
-   end;
-
-end;  (* TheoryPP *)

Deleted: HOL/src/0/Thm-sig.sml
===================================================================
--- HOL/src/0/Thm-sig.sml	2010-12-15 12:03:03 UTC (rev 8801)
+++ HOL/src/0/Thm-sig.sml	2010-12-16 03:54:31 UTC (rev 8802)
@@ -1,114 +0,0 @@
-signature Thm =
-sig
-  type thm
-  type tag
-  type term
-  type hol_type
-  type 'a set   = 'a HOLset.set
-
-
-  (* Simple operations on the type of theorems *)
-
-  val tag           : thm -> tag
-  val hyp           : thm -> term list
-  val hypset        : thm -> term set
-  val concl         : thm -> term
-  val dest_thm      : thm -> term list * term
-  val thm_frees     : thm -> term list
-  val hyp_frees     : thm -> term set
-  val hyp_tyvars    : thm -> hol_type set
-
-
-  (* The primitive rules of inference *)
-
-  val ASSUME        : term -> thm
-  val REFL          : term -> thm
-  val BETA_CONV     : term -> thm
-  val ABS           : term -> thm -> thm
-  val DISCH         : term -> thm -> thm
-  val MP            : thm -> thm -> thm
-  val SUBST         : (term,thm)Lib.subst -> term -> thm -> thm
-  val INST_TYPE     : (hol_type,hol_type)Lib.subst -> thm -> thm
-
-
-  (* Now some derivable-but-primitive rules of inference *)
-
-
-  (* Lambda calculus rules *)
-
-  val ALPHA         : term -> term -> thm
-  val MK_COMB       : thm * thm -> thm
-  val AP_TERM       : term -> thm -> thm
-  val AP_THM        : thm -> term -> thm
-
-
-  (* Equality *)
-
-  val SYM           : thm -> thm
-  val TRANS         : thm -> thm -> thm
-  val EQ_MP         : thm -> thm -> thm
-  val EQ_IMP_RULE   : thm -> thm * thm
-
-
-  (* Free variable instantiation *)
-
-  val INST          : (term,term)Lib.subst -> thm -> thm
-
-
-  (* Universal quantification *)
-
-  val SPEC          : term -> thm -> thm
-  val GEN           : term -> thm -> thm
-  val GENL          : term list -> thm -> thm
-
-
-  (* Existential quantification *)
-
-  val EXISTS        : term * term -> thm -> thm
-  val CHOOSE        : term * thm -> thm -> thm
-
-
-  (* Conjunction *)
-
-  val CONJ          : thm -> thm -> thm
-  val CONJUNCT1     : thm -> thm
-  val CONJUNCT2     : thm -> thm
-
-
-  (* Disjunction *)
-
-  val DISJ1         : thm -> term -> thm
-  val DISJ2         : term -> thm -> thm
-  val DISJ_CASES    : thm -> thm -> thm -> thm
-
-
-  (* Negation *)
-
-  val NOT_INTRO     : thm -> thm
-  val NOT_ELIM      : thm -> thm
-  val CCONTR        : term -> thm -> thm
-
-
-  (* Computing with explicit substitutions *)
-
-  val Beta          : thm -> thm
-  val Mk_comb       : thm -> thm * thm * (thm -> thm -> thm)
-  val Mk_abs        : thm -> term * thm * (thm -> thm)
-  val Specialize    : term -> thm -> thm
-
-  (* Multiple binders *)
-
-  val GEN_ABS       : term option -> term list -> thm -> thm
-
-  (* Oracle invocation *)
-
-  val mk_thm        : term list * term -> thm
-  val mk_oracle_thm : string -> term list * term -> thm
-  val add_tag       : tag * thm -> thm
-
-  (* Fetching theorems from disk *)
-
-  val disk_thm      : term vector
-                       -> string list * 'a Portable.frag list list
-                                      * 'a Portable.frag list -> thm
-end;

Added: HOL/src/0/Thm.sig
===================================================================
--- HOL/src/0/Thm.sig	                        (rev 0)
+++ HOL/src/0/Thm.sig	2010-12-16 03:54:31 UTC (rev 8802)
@@ -0,0 +1,7 @@
+signature Thm =
+sig
+
+  include FinalThm where type tag = Tag.tag
+                     and type hol_type = KernelTypes.hol_type
+                     and type term = KernelTypes.term
+end


Property changes on: HOL/src/0/Thm.sig
___________________________________________________________________
Added: svn:mime-type
   + text/plain
Added: svn:eol-style
   + native

Modified: HOL/src/0/Thm.sml
===================================================================
--- HOL/src/0/Thm.sml	2010-12-15 12:03:03 UTC (rev 8801)
+++ HOL/src/0/Thm.sml	2010-12-16 03:54:31 UTC (rev 8802)
@@ -12,7 +12,7 @@
 (*               : July 2000, Konrad Slind                               *)
 (* ===================================================================== *)
 
-structure Thm : RawThm =
+structure Thm :> Thm =
 struct
 
 open Feedback Lib Term KernelTypes Tag
@@ -1076,10 +1076,8 @@
 
 fun add_tag (tag1, THM(tag2, h,c)) = THM(Tag.merge tag1 tag2, h, c)
 
-
 (*---------------------------------------------------------------------------*
- *    The following two are only used in Theory, and are not                 *
- *     externally available.                                                 *
+ *    The following two are only used internally
  *---------------------------------------------------------------------------*)
 
 fun mk_axiom_thm (r,c) =
@@ -1090,99 +1088,145 @@
    (Assert (type_of c = bool) "mk_defn_thm"  "Not a proposition!";
     make_thm Count.Definition (witness_tag,empty_hyp,c))
 
+(* ----------------------------------------------------------------------
+    Primitive Definition Principles
+   ---------------------------------------------------------------------- *)
 
+fun ERR f msg = HOL_ERR {origin_structure = "Thm",
+                         origin_function = f, message = msg}
+val TYDEF_ERR = ERR "prim_type_definition"
+val DEF_ERR   = ERR "new_definition"
+val SPEC_ERR  = ERR "new_specification"
 
-(*---------------------------------------------------------------------------*
- * Fetching theorems from disk. The following parses the "raw" term          *
- * representation found in exported theory files.                            *
- *---------------------------------------------------------------------------*)
+val TYDEF_FORM_ERR = TYDEF_ERR "expected a theorem of the form \"?x. P x\""
+val DEF_FORM_ERR   = DEF_ERR   "expected a term of the form \"v = M\""
 
-datatype lexeme
-   = dot
-   | lamb
-   | lparen
-   | rparen
-   | ident of int
-   | bvar  of int;
+(* some simple term manipulation functions *)
+fun mk_exists (absrec as (Bvar,_)) =
+  mk_comb(mk_thy_const{Name="?",Thy="bool", Ty= (type_of Bvar-->bool)-->bool},
+          mk_abs absrec)
 
-local val numeric = Char.contains "0123456789"
+fun dest_eq M =
+  let val (Rator,r) = dest_comb M
+      val (eq,l) = dest_comb Rator
+  in case dest_thy_const eq
+      of {Name="=",Thy="min",...} => (l,r)
+       | _ => raise ERR "dest_eq" "not an equality"
+  end;
+
+fun mk_eq (lhs,rhs) =
+ let val ty = type_of lhs
+     val eq = mk_thy_const{Name="=",Thy="min",Ty=ty-->ty-->bool}
+ in list_mk_comb(eq,[lhs,rhs])
+ end;
+
+fun nstrip_exists 0 t = ([],t)
+  | nstrip_exists n t =
+     let val (Bvar, Body) = dest_exists t
+         val (l,t'') = nstrip_exists (n-1) Body
+     in (Bvar::l, t'')
+     end;
+
+(* standard checks *)
+fun check_null_hyp th f =
+  if null(hyp th) then ()
+  else raise f "theorem must have no assumptions";
+
+fun check_free_vars tm f =
+  case free_vars tm
+   of [] => ()
+    | V  => raise f (String.concat
+            ("Free variables in rhs of definition: "
+             :: commafy (map (Lib.quote o fst o dest_var) V)));
+
+fun check_tyvars body_tyvars ty f =
+ case Lib.set_diff body_tyvars (Type.type_vars ty)
+  of [] => ()
+   | extras =>
+      raise f (String.concat
+         ("Unbound type variable(s) in definition: "
+           :: commafy (map (Lib.quote o Type.dest_vartype) extras)));
+
+fun prim_type_definition (name as {Thy, Tyop}, thm) = let
+  val (_,Body)  = with_exn dest_exists (concl thm) TYDEF_FORM_ERR
+  val P         = with_exn rator Body TYDEF_FORM_ERR
+  val Pty       = type_of P
+  val (dom,rng) = with_exn Type.dom_rng Pty TYDEF_FORM_ERR
+  val tyvars    = Listsort.sort Type.compare (type_vars_in_term P)
+  val checked   = check_null_hyp thm TYDEF_ERR
+  val checked   =
+      assert_exn null (free_vars P)
+                 (TYDEF_ERR "subset predicate must be a closed term")
+  val checked   = assert_exn (op=) (rng,bool)
+                             (TYDEF_ERR "subset predicate has the wrong type")
+  val   _       = Type.prim_new_type name (List.length tyvars)
+  val newty     = Type.mk_thy_type{Tyop=Tyop,Thy=Thy,Args=tyvars}
+  val repty     = newty --> dom
+  val rep       = mk_primed_var("rep", repty)
+  val TYDEF     = mk_thy_const{Name="TYPE_DEFINITION", Thy="bool",
+                               Ty = Pty --> (repty-->bool)}
 in
-fun take_numb ss0 =
-  let val (ns, ss1) = Substring.splitl numeric ss0
-  in case Int.fromString (Substring.string ns)
-      of SOME i => (i,ss1)
-       | NONE   => ERR "take_numb" ""
-  end
-end;
+  mk_defn_thm(tag thm, mk_exists(rep, list_mk_comb(TYDEF,[P,rep])))
+end
 
-(* don't allow numbers to be split across fragments *)
+fun prim_constant_definition Thy M = let
+  val (lhs, rhs) = with_exn dest_eq M DEF_FORM_ERR
+  val {Name, Thy, Ty} =
+      if is_const lhs then let
+          val r as {Name, Ty, ...} = dest_thy_const lhs
+          (* note how we ignore the constant's theory; this is because the
+             user may be defining another version of an earlier constant *)
+        in
+          {Name = Name, Thy = Thy, Ty = Ty}
+        end
+      else if is_var lhs then let
+          val (n, ty) = dest_var lhs
+        in
+          {Name = n, Ty = ty, Thy = Thy}
+        end
+      else raise DEF_FORM_ERR
+  val checked = check_free_vars rhs DEF_ERR
+  val checked = check_tyvars (type_vars_in_term rhs) Ty DEF_ERR
+  val new_lhs = Term.prim_new_const {Name = Name, Thy = Thy} Ty
+in
+  mk_defn_thm(empty_tag, mk_eq(new_lhs, rhs))
+end
 
-fun lexer (ss1,qs1) =
-  case Substring.getc (Lib.deinitcommentss ss1)
-                      (* was: (Substring.dropl Char.isSpace ss1) *)
-   of NONE => (case qs1
-                of (QUOTE s::qs2) => lexer (Substring.full s,qs2)
-                 | []             => NONE
-                 | _              => ERR "raw lexer" "expected a quotation")
-    | SOME (c,ss2) =>
-       case c
-        of #"."  => SOME(dot,   (ss2,qs1))
-         | #"\\" => SOME(lamb,  (ss2,qs1))
-         | #"("  => SOME(lparen,(ss2,qs1))
-         | #")"  => SOME(rparen,(ss2,qs1))
-         | #"%"  => let val (n,ss3) = take_numb ss2 in SOME(ident n, (ss3,qs1)) end
-         | #"$"  => let val (n,ss3) = take_numb ss2 in SOME(bvar n,  (ss3,qs1)) end
-         |   _   => ERR "raw lexer" "bad character";
+fun bind thy s ty =
+    Term.prim_new_const {Name = s, Thy = thy} ty
 
-fun eat_rparen ss =
-  case lexer ss
-   of SOME (rparen, ss') => ss'
-    |   _ => ERR "eat_rparen" "expected right parenthesis";
+fun prim_specification thyname cnames th = let
+  val con       = concl th
+  val checked   = check_null_hyp th SPEC_ERR
+  val checked   = check_free_vars con SPEC_ERR
+  val checked   =
+      assert_exn (op=) (length(mk_set cnames),length cnames)
+                 (SPEC_ERR "duplicate constant names in specification")
+  val (V,body)  =
+      with_exn (nstrip_exists (length cnames)) con
+               (SPEC_ERR "too few existentially quantified variables")
+  fun vOK V v   = check_tyvars V (type_of v) SPEC_ERR
+  val checked   = List.app (vOK (type_vars_in_term body)) V
+  fun addc v s  = v |-> bind thyname s (snd(dest_var v))
+in
+  mk_defn_thm (tag th, subst (map2 addc V cnames) body)
+end
 
-fun eat_dot ss =
-  case lexer ss
-   of SOME (dot, ss') => ss'
-    |   _ => ERR "eat_dot" "expected a \".\"";
 
-fun parse_raw table =
- let fun index i = Vector.sub(table,i)
-     fun parse (stk,ss) =
-      case lexer ss
-       of SOME (bvar n,  rst) => (Bv n::stk,rst)
-        | SOME (ident n, rst) => (index n::stk,rst)
-        | SOME (lparen,  rst) =>
-           (case lexer rst
-             of SOME (lamb, rst') => parse (glamb (stk,rst'))
-              |    _              => parse (parsel (parse (stk,rst))))
-        |  _ => (stk,ss)
-     and
-     parsel (stk,ss) =
-        case parse (stk,ss)
-         of (h1::h2::t, ss') => (Comb(h2,h1)::t, eat_rparen ss')
-          |   _              => ERR "raw.parsel" "impossible"
-     and
-     glamb(stk,ss) =
-      case lexer ss
-       of SOME (ident n, rst) =>
-            (case parse (stk, eat_dot rst)
-              of (h::t,rst1) => (Abs(index n,h)::t, eat_rparen rst1)
-               |   _         => ERR "glamb" "impossible")

@@ Diff output truncated at 100000 characters. @@

This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 8804
          http://hol.svn.sourceforge.net/hol/?rev=8804&view=rev
Author:   michaeln
Date:     2010-12-16 04:05:56 +0000 (Thu, 16 Dec 2010)

Log Message:
-----------
Give svn:ignore property to a couple of recent new directories.

Property Changed:
----------------
    HOL/examples/machine-code/instruction-set-models/x86_64/
    HOL/src/postkernel/


Property changes on: HOL/examples/machine-code/instruction-set-models/x86_64
___________________________________________________________________
Added: svn:ignore
   + *.uo
*.ui
*Theory.sig
*Theory.sml
selftest.exe
.HOLMK



Property changes on: HOL/src/postkernel
___________________________________________________________________
Added: svn:ignore
   + *.uo
*.ui
*Theory.sig
*Theory.sml
selftest.exe
.HOLMK



This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 8807
          http://hol.svn.sourceforge.net/hol/?rev=8807&view=rev
Author:   michaeln
Date:     2010-12-16 23:18:06 +0000 (Thu, 16 Dec 2010)

Log Message:
-----------
Move kernelid variable to Thm so that it isn't shared across kernels.

Thanks to Anthony for spotting the problem.

Modified Paths:
--------------
    HOL/src/0/Thm.sml
    HOL/src/experimental-kernel/Thm.sml
    HOL/src/postkernel/Theory.sml
    HOL/src/prekernel/FinalTheory-sig.sml
    HOL/src/prekernel/FinalThm-sig.sml
    HOL/std.prelude
    HOL/tools-poly/prelude.ML

Modified: HOL/src/0/Thm.sml
===================================================================
--- HOL/src/0/Thm.sml	2010-12-16 04:41:28 UTC (rev 8806)
+++ HOL/src/0/Thm.sml	2010-12-16 23:18:06 UTC (rev 8807)
@@ -23,6 +23,8 @@
 infixr 3 -->;
 infix 5 |-> ;
 
+val kernelid = "stdknl"
+
 (*---------------------------------------------------------------------------
        Exception handling
  ---------------------------------------------------------------------------*)

Modified: HOL/src/experimental-kernel/Thm.sml
===================================================================
--- HOL/src/experimental-kernel/Thm.sml	2010-12-16 04:41:28 UTC (rev 8806)
+++ HOL/src/experimental-kernel/Thm.sml	2010-12-16 23:18:06 UTC (rev 8807)
@@ -24,6 +24,8 @@
 infixr 3 -->;
 infix 5 |-> ;
 
+val kernelid = "expknl"
+
 (*---------------------------------------------------------------------------
        Exception handling
  ---------------------------------------------------------------------------*)

Modified: HOL/src/postkernel/Theory.sml
===================================================================
--- HOL/src/postkernel/Theory.sml	2010-12-16 04:41:28 UTC (rev 8806)
+++ HOL/src/postkernel/Theory.sml	2010-12-16 23:18:06 UTC (rev 8807)
@@ -60,7 +60,6 @@
 
 val ERR  = mk_HOL_ERR "Theory";
 val WARN = HOL_WARNING "Theory";
-val kernelid = "expknl"
 
 type thy_addon = {sig_ps    : (ppstream -> unit) option,
                   struct_ps : (ppstream -> unit) option}

Modified: HOL/src/prekernel/FinalTheory-sig.sml
===================================================================
--- HOL/src/prekernel/FinalTheory-sig.sml	2010-12-16 04:41:28 UTC (rev 8806)
+++ HOL/src/prekernel/FinalTheory-sig.sml	2010-12-16 23:18:06 UTC (rev 8807)
@@ -9,8 +9,6 @@
                     struct_ps : (ppstream -> unit) option}
   type num = Arbnum.num
 
-  val kernelid : string
-
 (* Create a new theory *)
 
   val new_theory         : string -> unit

Modified: HOL/src/prekernel/FinalThm-sig.sml
===================================================================
--- HOL/src/prekernel/FinalThm-sig.sml	2010-12-16 04:41:28 UTC (rev 8806)
+++ HOL/src/prekernel/FinalThm-sig.sml	2010-12-16 23:18:06 UTC (rev 8807)
@@ -6,6 +6,7 @@
   type hol_type
   type 'a set   = 'a HOLset.set
 
+  val kernelid : string
 
   (* Simple operations on the type of theorems *)
 

Modified: HOL/std.prelude
===================================================================
--- HOL/std.prelude	2010-12-16 04:41:28 UTC (rev 8806)
+++ HOL/std.prelude	2010-12-16 23:18:06 UTC (rev 8807)
@@ -149,7 +149,7 @@
    "\n---------------------------------------------------------------------\n"
   ^"       HOL-4 ["
   ^Globals.release^" "^Lib.int_to_string(Globals.version)
-  ^" ("^Theory.kernelid^", "^build_stamp
+  ^" ("^Thm.kernelid^", "^build_stamp
   ^")]\n\n       For introductory HOL help, type: help \"hol\";\n"
   ^"\n---------------------------------------------------------------------\n\
    \\n");

Modified: HOL/tools-poly/prelude.ML
===================================================================
--- HOL/tools-poly/prelude.ML	2010-12-16 04:41:28 UTC (rev 8806)
+++ HOL/tools-poly/prelude.ML	2010-12-16 23:18:06 UTC (rev 8807)
@@ -132,7 +132,7 @@
    "\n---------------------------------------------------------------------\n"
   ^"       HOL-4 ["
   ^Globals.release^" "^Lib.int_to_string(Globals.version)
-  ^" ("^Theory.kernelid^", "^build_stamp^")"
+  ^" ("^Thm.kernelid^", "^build_stamp^")"
   ^"]\n\n       For introductory HOL help, type: help \"hol\";"
   ^"\n---------------------------------------------------------------------\n\
    \\n")


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 8839
          http://hol.svn.sourceforge.net/hol/?rev=8839&view=rev
Author:   xrchz
Date:     2011-01-09 13:40:54 +0000 (Sun, 09 Jan 2011)

Log Message:
-----------
Add Opentheory module with read_article function

This is an alpha-quality implementation and contains many (unknown) bugs.

Comments on design decisions welcome.

read_article :
  instream ->
  {thms   : thm net,
   types  : (string, hol_type list -> hol_type) dict,
   consts : (string, hol_type -> term) dict} ->
  thm list
takes an article and a record of theorems, types and constants the
article might require, processes it, and returns the exported theorems.

opentheory can tell you what thms types and consts a package would need,
and read_article should raise informative errors if you don't provide
something.

Also include a selftest that processes the article for bool-def-1.0, a
package that appears to come with opentheory in the "gilith" repository.
But I don't yet test that the generated theorems match what the article
is supposed to produce, because that probably first requires
implementing a parser for the output of opentheory info --summary.
(Don't want to list them by hand...)

Modified Paths:
--------------
    HOL/tools/build-sequence

Added Paths:
-----------
    HOL/src/opentheory/
    HOL/src/opentheory/Holmakefile
    HOL/src/opentheory/Opentheory.sig
    HOL/src/opentheory/Opentheory.sml
    HOL/src/opentheory/selftest.sml

Added: HOL/src/opentheory/Holmakefile
===================================================================
--- HOL/src/opentheory/Holmakefile	                        (rev 0)
+++ HOL/src/opentheory/Holmakefile	2011-01-09 13:40:54 UTC (rev 8839)
@@ -0,0 +1,2 @@
+selftest.exe: selftest.uo Opentheory.uo
+	$(HOLMOSMLC) -o $@ $<


Property changes on: HOL/src/opentheory/Holmakefile
___________________________________________________________________
Added: svn:mime-type
   + text/plain
Added: svn:eol-style
   + native

Added: HOL/src/opentheory/Opentheory.sig
===================================================================
--- HOL/src/opentheory/Opentheory.sig	                        (rev 0)
+++ HOL/src/opentheory/Opentheory.sig	2011-01-09 13:40:54 UTC (rev 8839)
@@ -0,0 +1,12 @@
+signature Opentheory = sig
+  type thms   = Thm.thm Net.net
+  type types  = (string, Type.hol_type list -> Type.hol_type) Redblackmap.dict
+  type consts = (string, Type.hol_type -> Term.term) Redblackmap.dict
+  val empty_thms     : thms
+  val empty_types    : types
+  val empty_consts   : consts
+  val thmsFromList   : Thm.thm list -> thms
+  val typesFromList  : (string * (Type.hol_type list -> Type.hol_type)) list -> types
+  val constsFromList : (string * (Type.hol_type -> Term.term)) list -> consts
+  val read_article   : TextIO.instream -> {thms:thms,types:types,consts:consts} -> Thm.thm list
+end


Property changes on: HOL/src/opentheory/Opentheory.sig
___________________________________________________________________
Added: svn:mime-type
   + text/plain
Added: svn:eol-style
   + native

Added: HOL/src/opentheory/Opentheory.sml
===================================================================
--- HOL/src/opentheory/Opentheory.sml	                        (rev 0)
+++ HOL/src/opentheory/Opentheory.sml	2011-01-09 13:40:54 UTC (rev 8839)
@@ -0,0 +1,221 @@
+structure Opentheory :> Opentheory = struct
+
+val ERR = Feedback.mk_HOL_ERR "Opentheory"
+
+structure Map = Redblackmap
+type thms   = Thm.thm Net.net
+type types  = (string, Type.hol_type list -> Type.hol_type) Map.dict
+type consts = (string, Type.hol_type -> Term.term) Map.dict
+
+val empty_thms     = Net.empty
+val empty_types    = Map.mkDict String.compare
+val empty_consts   = Map.mkDict String.compare
+val thmsFromList   = List.foldl (fn (th,n) => Net.insert(Thm.concl th,th) n) empty_thms
+val typesFromList  = Map.fromList String.compare
+val constsFromList = Map.fromList String.compare
+
+datatype object
+= ONum of int
+| OName of string
+| OList of object list
+| OTypeOp of string
+| OType of Type.hol_type
+| OConst of string
+| OVar of Term.term
+| OTerm of Term.term
+| OThm of Thm.thm
+
+datatype command
+= Num of int
+| Name of string
+| AbsTerm
+| AbsThm
+| AppTerm
+| AppThm
+| Assume
+| Axiom
+| BetaConv
+| Cons
+| Const
+| ConstTerm
+| DeductAntisym
+| Def
+| DefineConst
+| DefineTypeOp
+| EqMp
+| Nil
+| OpType
+| Pop
+| Ref
+| Refl
+| Remove
+| Subst
+| Thm
+| TypeOp
+| Var
+| VarTerm
+| VarType
+
+fun st_ (st,{stack,dict,thms}) = {stack=st,dict=dict,thms=thms}
+fun push (ob,state) = st_ (ob::(#stack state),state)
+
+fun find_thm thms (h,c) = let
+  val candidates = Net.index c thms
+  fun equal thm = let
+    val c' = Thm.concl thm
+    val thm' = Drule.PART_MATCH Lib.I thm (#2(boolSyntax.strip_forall c))
+  in Lib.set_eq h (Thm.hyp thm') end handle Feedback.HOL_ERR _ => false
+  val SOME th = List.find equal candidates
+in th end
+
+fun find_const consts (n,t) = Map.find(consts,n) t
+handle Map.NotFound => Term.mk_const(n,t)
+handle Feedback.HOL_ERR _ => raise ERR "find_const" ("need "^n^" of type "^(Parse.type_to_string t))
+
+local open Thm Drule in
+fun DEDUCT_ANTISYM th1 th2 =
+  IMP_ANTISYM_RULE
+    (DISCH (concl th1) th2)
+    (DISCH (concl th2) th1)
+end
+
+val unOTermls = List.map (fn OTerm t => t)
+val unOTypels = List.map (fn OType t => t)
+val unONamels = List.map (fn OName n => n)
+
+fun find_type types (t,ls) = let
+  val ls = unOTypels ls
+in
+  (Map.find(types,t)) ls
+  handle Map.NotFound => let
+    val s = Parse.type_to_string(Type.mk_type(t,ls))
+    handle Feedback.HOL_ERR _ =>
+    (* PolyML.makestring (t, (Map.listItems types)) *)
+    ("TyOp = "^t^", Args = "^(String.concatWith ", " (List.map Parse.type_to_string ls)))
+  in raise ERR "find_type" ("need "^s) end
+end
+
+exception Comment
+
+fun
+  parse_line "absTerm"       = AbsTerm
+| parse_line "absThm"        = AbsThm
+| parse_line "appTerm"       = AppTerm
+| parse_line "appThm"        = AppThm
+| parse_line "assume"        = Assume
+| parse_line "axiom"         = Axiom
+| parse_line "betaConv"      = BetaConv
+| parse_line "cons"          = Cons
+| parse_line "const"         = Const
+| parse_line "constTerm"     = ConstTerm
+| parse_line "deductAntisym" = DeductAntisym
+| parse_line "def"           = Def
+| parse_line "defineConst"   = DefineConst
+| parse_line "defineTypeOp"  = DefineTypeOp
+| parse_line "eqMp"          = EqMp
+| parse_line "nil"           = Nil
+| parse_line "opType"        = OpType
+| parse_line "pop"           = Pop
+| parse_line "ref"           = Ref
+| parse_line "refl"          = Refl
+| parse_line "remove"        = Remove
+| parse_line "subst"         = Subst
+| parse_line "thm"           = Thm
+| parse_line "typeOp"        = TypeOp
+| parse_line "var"           = Var
+| parse_line "varTerm"       = VarTerm
+| parse_line "varType"       = VarType
+| parse_line s = let
+    val c = String.sub(s,0)
+  in if c = #"\"" then Name (String.substring(s,1,String.size s -2)) else
+     if Char.isDigit c then Num (Option.valOf (Int.fromString s))
+     else raise Comment
+  end
+
+fun read_article file {types,consts,thms} = let
+  val find_asm   = find_thm thms
+  val find_const = find_const consts
+  val find_type  = find_type types
+  fun f (Num i)  st = push(ONum i,st)
+    | f (Name s) st = push(OName s,st)
+    | f AbsTerm  (st as {stack=OTerm b::OVar v::os,...})  = st_(OTerm(Term.mk_abs(v,b))::os,st)
+    | f AppTerm  (st as {stack=OTerm x::OTerm f::os,...}) = st_(OTerm(Term.mk_comb(f,x))::os,st)
+    | f AppThm   (st as {stack=OThm xy::OThm fg::os,...}) = let
+        val (f,g) = boolSyntax.dest_eq(Thm.concl fg)
+        val (x,y) = boolSyntax.dest_eq(Thm.concl xy)
+        val fxgx  = Thm.AP_THM fg x
+        val gxgy  = Thm.AP_TERM g xy
+      in st_(OThm(Thm.TRANS fxgx gxgy)::os,st) end
+    | f Assume        (st as {stack=OTerm t::os,...})           = st_(OThm(Thm.ASSUME t)::os,st)
+    | f Axiom         (st as {stack=OTerm t::OList ts::os,...}) = st_(OThm(find_asm(unOTermls ts,t))::os,st)
+    | f BetaConv      (st as {stack=OTerm t::os,...})           = st_(OThm(Thm.BETA_CONV t)::os,st)
+    | f Cons          (st as {stack=OList t::h::os,...})        = st_(OList(h::t)::os,st)
+    | f Const         (st as {stack=OName n::os,...})           = st_(OConst n::os,st)
+    | f ConstTerm     (st as {stack=OType t::OConst c::os,...}) = st_(OTerm(find_const (c,t))::os,st)
+    | f DeductAntisym (st as {stack=OThm t1::OThm t2::os,...})  = st_(OThm(DEDUCT_ANTISYM t1 t2)::os,st)
+    | f Def           {stack=ONum k::x::os,dict,thms}           = {stack=x::os,dict=Map.insert(dict,k,x),thms=thms}
+    | f DefineConst   (st as {stack=OTerm t::OName n::os,...})  = let
+        val t = boolSyntax.mk_eq(Term.mk_var(n,Term.type_of t),t)
+        val def = Definition.new_definition(n,t)
+        handle Feedback.HOL_ERR _ => raise ERR "read_article" ("DefineConst "^n^" by "^Parse.term_to_string t^" failed")
+      in st_(OThm def::OConst n::os,st) end
+    | f DefineTypeOp  (st as {stack=OThm th::OList ls::OName rep::OName abs::OName n::os,...}) = let
+        val ls = unONamels ls
+        val sorted = Lib.sort (Lib.curry (Lib.equal LESS o String.compare)) ls
+        val s = let fun f (a,a',s) = if a = a' then s else let
+                      val a = Type.mk_vartype a
+                      val a' = Type.mk_vartype a'
+                      val op |-> = Lib.|-> infix |->
+                    in (a |-> a')::(a' |-> a)::s end
+                in ListPair.foldlEq f [] (ls,sorted) end
+        val th = Thm.INST_TYPE s th
+        val Pt = Thm.concl th
+        val (P,t) = Term.dest_comb(Pt)
+        val th = Thm.EXISTS(boolSyntax.mk_exists(t,Pt),t) th
+        val tyax = Definition.new_type_definition(n,th)
+        val th = Drule.define_new_type_bijections {name=n^"_repfns",ABS=abs,REP=rep,tyax=tyax}
+        val th1 = Drule.SPEC_ALL (Thm.CONJUNCT1 th)
+        val th2 = Drule.SPEC_ALL (Thm.CONJUNCT2 th)
+      in st_(OThm th2::OThm  th1::OConst rep::OConst abs::OTypeOp n::os,st) end
+    | f EqMp   (st as {stack=OThm fg::OThm f::os,...})     = st_(OThm(Thm.EQ_MP fg f)::os,st)
+    | f Nil    st                                          = push(OList [],st)
+    | f OpType (st as {stack=OList ls::OTypeOp t::os,...}) = st_(OType(find_type(t,ls))::os,st)
+    | f Pop    (st as {stack=x::os,...})                   = st_(os,st)
+    | f Ref    (st as {stack=ONum k::os,dict,...})         = st_(Map.find(dict,k)::os,st)
+    | f Refl   (st as {stack=OTerm t::os,...})             = st_(OThm(Thm.REFL t)::os,st)
+    | f Remove {stack=ONum k::os,dict,thms}                = let
+        val (dict,x) = Map.remove(dict,k)
+      in {stack=x::os,dict=dict,thms=thms} end
+    | f Subst  (st as {stack=OThm th::OList[OList tys,OList tms]::os,...}) = let
+        val tys = List.map (fn OList [OName a, OType t] => {redex=Type.mk_vartype a, residue=t}) tys
+        val tms = List.map (fn OList [OVar v, OTerm t] => {redex=v, residue=t}) tms
+        val th = Thm.INST_TYPE tys th
+        val th = Thm.INST tms th
+      in st_(OThm th::os,st) end
+    | f Thm    {stack=OTerm c::OList ls::OThm th::os,dict,thms} = let
+        val th = Thm.EQ_MP (Thm.ALPHA (Thm.concl th) c) th
+        fun ft (OTerm h, th) = let
+          val c = Thm.concl th
+          val th = Thm.DISCH h th
+          val c' = Thm.concl th
+        in
+          if Term.aconv c c' then
+            Drule.ADD_ASSUM h th
+          else let
+            val (h',_) = boolSyntax.dest_imp c'
+            val h'h = Thm.ALPHA h' h
+            val th = Drule.SUBS_OCCS [([1],h'h)] th
+          in Drule.UNDISCH th end
+        end
+        val th = List.foldl ft th ls
+      in {stack=os,dict=dict,thms=th::thms} end
+    | f TypeOp  (st as {stack=OName n::os,...})          = st_(OTypeOp n::os,st)
+    | f Var     (st as {stack=OType t::OName n::os,...}) = st_(OVar(Term.mk_var(n,t))::os,st)
+    | f VarTerm (st as {stack=OVar t::os,...})           = st_(OTerm t::os,st)
+    | f VarType (st as {stack=OName n::os,...})          = st_(OType(Type.mk_vartype n)::os,st)
+  fun stripnl s = let open Substring in string(trimr 1 (full s)) end
+  fun loop x = case TextIO.inputLine file of
+    NONE => x before TextIO.closeIn(file)
+  | SOME line => loop (f (parse_line (stripnl line)) x handle Comment => x)
+in #thms (loop {stack=[],dict=Map.mkDict(Int.compare),thms=[]}) end
+end


Property changes on: HOL/src/opentheory/Opentheory.sml
___________________________________________________________________
Added: svn:mime-type
   + text/plain
Added: svn:eol-style
   + native

Added: HOL/src/opentheory/selftest.sml
===================================================================
--- HOL/src/opentheory/selftest.sml	                        (rev 0)
+++ HOL/src/opentheory/selftest.sml	2011-01-09 13:40:54 UTC (rev 8839)
@@ -0,0 +1,17 @@
+open Opentheory
+fun cmd pkg out = ("opentheory info --article -o "^out^" "^pkg)
+val pkg = "bool-def-1.0"
+val tmp = OS.FileSys.tmpName()
+val _ = if OS.Process.isSuccess(Systeml.system_ps (cmd pkg tmp)) then let
+val thms = read_article (TextIO.openIn tmp) {
+  thms=empty_thms,
+  types=typesFromList
+  [("bool",fn [] => Type.bool),
+   ("->",fn ls => Type.mk_type("fun",ls))],
+  consts=constsFromList
+  [("=",fn ty => Term.mk_const("=",ty)),
+   ("Data.Bool.select",fn ty => Term.mk_const("@",ty))]}
+val thms = thmsFromList thms
+(* TODO: check that thms is the same set that opentheory
+         says the package should have produced *)
+in () end else ()


Property changes on: HOL/src/opentheory/selftest.sml
___________________________________________________________________
Added: svn:mime-type
   + text/plain
Added: svn:eol-style
   + native

Modified: HOL/tools/build-sequence
===================================================================
--- HOL/tools/build-sequence	2011-01-09 10:16:58 UTC (rev 8838)
+++ HOL/tools/build-sequence	2011-01-09 13:40:54 UTC (rev 8839)
@@ -116,6 +116,7 @@
 !!examples/separationLogic/src/
 src/HolQbf
 src/HolSmt
+src/opentheory
 !examples/misc
 # these examples require Muddy, which is MoscowML specific
 [mosml]!examples/muddy/muddyC


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 8844
          http://hol.svn.sourceforge.net/hol/?rev=8844&view=rev
Author:   michaeln
Date:     2011-01-10 06:01:44 +0000 (Mon, 10 Jan 2011)

Log Message:
-----------
Add definition of rpow function, contributed by Umair Siddique.

This is exponentiation where both arguments are real numbers.  Hitherto,
realTheory has only had pow, where the exponent had to be a natural
number.

Document this in release notes.

Modified Paths:
--------------
    HOL/doc/kananaskis-7.release.html
    HOL/src/real/transcScript.sml

Modified: HOL/doc/kananaskis-7.release.html
===================================================================
--- HOL/doc/kananaskis-7.release.html	2011-01-10 06:01:13 UTC (rev 8843)
+++ HOL/doc/kananaskis-7.release.html	2011-01-10 06:01:44 UTC (rev 8844)
@@ -46,6 +46,15 @@
 
 <h2 id="new-theories">New theories:</h2>
 
+<ul>
+<li><p>The theory of transcendental functions (<code>transcTheory</code>)
+has been extended with a treatment of exponentiation where exponents
+can be of type <code>:real</code>.  This is implemented by the (infix)
+function <code>rpow</code>.  (The existing function <code>pow</code>
+requires a natural number as the exponent.)  Thanks to Umair Siddique
+for the definition and theorems.
+</ul>
+
 <h2 id="new-tools">New tools:</h2>
 
 <h2 id="new-examples">New examples:</h2>

Modified: HOL/src/real/transcScript.sml
===================================================================
--- HOL/src/real/transcScript.sml	2011-01-10 06:01:13 UTC (rev 8843)
+++ HOL/src/real/transcScript.sml	2011-01-10 06:01:44 UTC (rev 8844)
@@ -3583,6 +3583,292 @@
 val lem = prove(Term`!n:num. 0 < n ==> ~(n=0)`,
 INDUCT_TAC THEN ASM_REWRITE_TAC [NOT_SUC,NOT_LESS_0]);
 
+(* ----------------------------------------------------------------------
+    Exponentiation with real exponents
+
+    Contributed by
+
+       Umair Siddique
+
+       Email: umair.siddique@...
+       DATE: 29-12-2010
+
+       System Analysis & Verification (sAvE)  LAB
+
+       National University of Sciences and Technology (NUST)
+       Ialamabad,Pakistan
+    ---------------------------------------------------------------------- *)
+
+fun K_TAC _ = ALL_TAC;
+
+open bossLib realSimps
+
+(* Definition *)
+val _ = set_fixity "rpow" (Infixr 700);
+
+val rpow = Define `a rpow b = exp (b * ln a)`;
+
+(* Properties *)
+
+val  GEN_RPOW = store_thm
+        ("GEN_RPOW",
+        ``! a n. 0 < a ==> (a pow n = a rpow  &n)``,
+ Induct_on `n` THENL [
+ RW_TAC real_ss [pow,POW_1, rpow, GSYM EXP_0],
+
+GEN_TAC THEN
+        RW_TAC std_ss[rpow,pow,REAL,REAL_RDISTRIB,EXP_ADD,REAL_MUL_LID] THEN
+
+        KNOW_TAC ``exp(ln a)= a`` THEN1
+          PROVE_TAC[EXP_LN] THEN
+        DISCH_TAC THEN ASM_REWRITE_TAC [] THEN POP_ASSUM K_TAC THEN
+        KNOW_TAC ``a* exp (&n * ln a) = exp (&n * ln a)*a`` THEN1
+          RW_TAC std_ss[REAL_MUL_COMM] THEN
+        DISCH_TAC THEN ASM_REWRITE_TAC [] THEN POP_ASSUM K_TAC]);
+
+val  RPOW_SUC_N = store_thm
+        ("RPOW_SUC_N",
+        ``!(a:real) (n:num). 0 < a ==>(a rpow (&n+1)= a pow SUC n)``,
+ RW_TAC std_ss [] THEN
+ KNOW_TAC``&n + (1:real)= & SUC n`` THEN1
+     RW_TAC std_ss [REAL]THEN
+       DISCH_TAC THEN ONCE_ASM_REWRITE_TAC[] THEN
+       RW_TAC std_ss [GEN_RPOW]) ;
+
+val RPOW_0= store_thm
+        ("RPOW_0",
+        ``! a. (0 < a)==> (a rpow  &0 = &1)``,
+  RW_TAC std_ss [rpow]THEN
+  RW_TAC std_ss [REAL_MUL_LZERO]THEN
+  RW_TAC std_ss [EXP_0]);
+
+val  RPOW_1= store_thm
+        ("RPOW_1",
+        ``! a. (0 < a)==> ( a rpow  &1 = a)``,
+   RW_TAC std_ss [GSYM GEN_RPOW,POW_1]);
+
+val  ONE_RPOW= store_thm
+        ("ONE_RPOW",
+        ``! a. (0 < a)==> (1 rpow a  = 1)``,
+RW_TAC real_ss [rpow,LN_1,EXP_0]);
+
+val  RPOW_POS_LT= store_thm
+        ("RPOW_POS_LT",
+        ``! a b. (0 < a)==> (0 < a rpow b)``,
+              RW_TAC std_ss [rpow, EXP_POS_LT]);
+
+val  RPOW_NZ= store_thm
+        ("RPOW_NZ",
+        ``! a b. (0 <> a)==> ( a rpow b <>0)``,
+RW_TAC std_ss [rpow,EXP_NZ]);
+
+
+val  LN_RPOW= store_thm
+        ("LN_RPOW",
+        ``! a b. (0 < a)==> (ln (a rpow b)= (b*ln a))``,
+ RW_TAC std_ss [rpow,LN_EXP]);
+
+val  RPOW_ADD= store_thm
+        ("RPOW_ADD",
+        ``! a b c. a rpow (b + c)= (a rpow  b)*(a rpow  c)``,
+ RW_TAC std_ss [rpow, EXP_ADD, REAL_RDISTRIB] );
+
+val  RPOW_ADD_MUL= store_thm
+        ("RPOW_ADD_MUL",
+        ``! a b c. a rpow (b + c)* a rpow (-b)= (a rpow c)``,
+ RW_TAC std_ss [rpow, REAL_RDISTRIB, GSYM EXP_ADD]THEN
+ KNOW_TAC`` ((b * ln a + c * ln a + -b * ln a)=(b * ln a  -b * ln a + c*ln a)) ``THEN1
+    REAL_ARITH_TAC THEN
+         DISCH_TAC THEN ASM_REWRITE_TAC[] THEN POP_ASSUM K_TAC THEN
+     KNOW_TAC``((b * ln a - b * ln a + c * ln a) = (c*ln a )) ``THEN1
+         REAL_ARITH_TAC THEN
+         RW_TAC real_ss []);
+
+val  RPOW_SUB= store_thm
+        ("RPOW_SUB",
+        ``! a b c. a rpow (b - c)= (a rpow b)/(a rpow c)``,
+RW_TAC std_ss [rpow, REAL_SUB_RDISTRIB, EXP_SUB]);
+
+val  RPOW_DIV= store_thm
+        ("RPOW_DIV",
+        ``! a b c.  (0 < a)/\ (0<b)==> ((a/b) rpow  c= (a rpow c)/(b rpow c))``,
+   RW_TAC std_ss [rpow ,LN_DIV, REAL_SUB_LDISTRIB, EXP_SUB]);
+
+val  RPOW_INV= store_thm
+        ("RPOW_INV",
+        ``! a b .  (0 < a)==>((inv a) rpow b= inv (a rpow b))``,
+
+RW_TAC real_ss [rpow, REAL_INV_1OVER, LN_DIV, REAL_SUB_LDISTRIB, EXP_SUB, LN_1, EXP_0]);
+
+
+val  RPOW_MUL= store_thm
+        ("RPOW_MUL",
+        ``! a b c. (0<a) /\ (0<b)==> (((a*b) rpow c)=(a rpow c)*(b rpow c))``,
+RW_TAC std_ss [rpow, LN_MUL, REAL_LDISTRIB, EXP_ADD]);
+
+val  RPOW_RPOW= store_thm
+        ("RPOW_RPOW",
+        ``! a b c. (0<a)==> ((a rpow b) rpow c = a rpow (b*c))``,
+  RW_TAC real_ss [rpow, LN_EXP, REAL_MUL_ASSOC] THEN
+  PROVE_TAC[ REAL_MUL_COMM] );
+
+
+val  RPOW_LT= store_thm
+        ("RPOW_LT",
+        ``! (a:real) (b:real) (c:real).(1 < a)==>((a rpow b < a rpow c)= b < c )``,
+ RW_TAC std_ss [rpow]  THEN
+ KNOW_TAC`` exp (b * ln a) < exp (c * ln a)= (b*ln a < c*ln a)``  THEN1
+      RW_TAC real_ss [EXP_MONO_LT]  THEN
+      DISCH_TAC THEN ASM_REWRITE_TAC[] THEN POP_ASSUM K_TAC  THEN
+      KNOW_TAC``((b:real)*ln a < (c:real)*ln a)= (b < c)``  THENL   [
+      MATCH_MP_TAC REAL_LT_RMUL  THEN
+      KNOW_TAC``0 < ln a = exp (0) < exp (ln a)``  THEN1
+         PROVE_TAC[EXP_MONO_LT]  THEN
+         DISCH_TAC  THEN
+         FULL_SIMP_TAC real_ss[]  THEN
+         RW_TAC real_ss [EXP_0]  THEN
+         KNOW_TAC``1 < (a:real) ==> 0 <(a:real)``  THENL [
+             RW_TAC real_ss []  THEN
+             MATCH_MP_TAC REAL_LT_TRANS  THEN
+             EXISTS_TAC``(1:real)`` THEN
+             RW_TAC real_ss [],
+             RW_TAC real_ss []  THEN
+             KNOW_TAC``exp (ln a)=(a:real)``  THEN1
+                  RW_TAC real_ss [EXP_LN] THEN
+                  DISCH_TAC THEN ASM_REWRITE_TAC[]],
+            RW_TAC real_ss []]);
+
+val  RPOW_LE = store_thm
+        ("RPOW_LE",
+        ``!a b c. (1 < a)==>((a rpow b <= a rpow c)= b <= c )``,
+ RW_TAC std_ss [rpow] THEN
+ KNOW_TAC`` exp ((b:real) * ln a) <= exp ((c:real) * ln a)= ((b:real)*ln a <= (c:real)*ln a)`` THEN1
+      RW_TAC real_ss [EXP_MONO_LE] THEN
+ DISCH_TAC THEN ASM_REWRITE_TAC[] THEN POP_ASSUM K_TAC THEN
+ KNOW_TAC``(b*ln a <= c*ln a)= ((b:real) <= (c:real))`` THENL[
+          MATCH_MP_TAC REAL_LE_RMUL THEN
+     KNOW_TAC``0 < ln a = exp (0) < exp (ln a)`` THEN1
+         PROVE_TAC[EXP_MONO_LT] THEN
+          DISCH_TAC THEN
+          FULL_SIMP_TAC real_ss[] THEN
+          RW_TAC real_ss [EXP_0] THEN
+     KNOW_TAC``1 < (a:real) ==> 0 <(a:real)`` THENL[
+          RW_TAC real_ss [] THEN
+          MATCH_MP_TAC REAL_LT_TRANS THEN
+          EXISTS_TAC``(1:real)`` THEN
+          RW_TAC real_ss [] ,
+          RW_TAC real_ss [] THEN
+          KNOW_TAC``exp (ln a)=(a:real)`` THEN1
+             RW_TAC real_ss [EXP_LN] THEN
+             DISCH_TAC THEN ASM_REWRITE_TAC[]],
+ RW_TAC real_ss []]);
+
+
+val  BASE_RPOW_LE= store_thm
+        ("BASE_RPOW_LE",
+        ``! a b c. (0 < a)/\ (0 < c)/\ (0 < b)==>((a rpow b <= c rpow b)= a <= c )``,
+RW_TAC std_ss [rpow, EXP_MONO_LE] THEN
+KNOW_TAC`` (((b:real) * ln a) <= ((b:real) * ln c))= ((ln a <= ln c))`` THENL[
+  MATCH_MP_TAC REAL_LE_LMUL   THEN
+  RW_TAC real_ss [],
+
+  DISCH_TAC THEN ASM_REWRITE_TAC[] THEN POP_ASSUM K_TAC  THEN
+  RW_TAC real_ss [LN_MONO_LE]]);
+
+val  BASE_RPOW_LT= store_thm
+        ("BASE_RPOW_LT",
+        ``! a b c. (0 < a)/\ (0 < c)/\ (0 < b)==>((a rpow b < c rpow b)= a < c )``,
+
+ RW_TAC std_ss [rpow, EXP_MONO_LT]  THEN
+ KNOW_TAC ``((b * ln a) < (b * ln c))= ((ln a < ln c))``  THENL[
+       MATCH_MP_TAC REAL_LT_LMUL  THEN
+       RW_TAC real_ss []  ,
+
+       DISCH_TAC THEN ASM_REWRITE_TAC[] THEN POP_ASSUM K_TAC  THEN
+       RW_TAC real_ss [LN_MONO_LT] ]);
+
+val  RPOW_UNIQ_BASE= store_thm (
+  "RPOW_UNIQ_BASE",
+  ``!a b c. 0 < a /\ 0 < c /\ 0 <> b /\ (a rpow b = c rpow b)==> (a = c)``,
+
+
+ RW_TAC std_ss [rpow, GSYM LN_INJ]THEN
+ POP_ASSUM MP_TAC  THEN
+ KNOW_TAC`` (exp (b * ln a) = exp (b * ln c)) = (ln (exp (b * ln a)) = ln (exp (b * ln c)))``THEN1
+     PROVE_TAC[LN_EXP]THEN
+     DISCH_TAC THEN ASM_REWRITE_TAC[] THEN POP_ASSUM K_TAC THEN
+     FULL_SIMP_TAC real_ss[LN_EXP] THEN
+     FULL_SIMP_TAC real_ss[REAL_EQ_MUL_LCANCEL]);
+
+
+val  RPOW_UNIQ_EXP = store_thm
+        ("RPOW_UNIQ_EXP",
+        ``!a b c. 1 < a /\ 0 < c /\ 0 < b /\ (a rpow b = a rpow c) ==>
+                  (b = c)``,
+ RW_TAC std_ss [rpow, GSYM LN_INJ] THEN
+ POP_ASSUM MP_TAC THEN
+ KNOW_TAC`` (exp (b * ln a) = exp (c * ln a)) = (ln (exp (b * ln a)) = ln (exp (c * ln a)))`` THEN1
+      PROVE_TAC[LN_EXP] THEN
+          DISCH_TAC THEN ASM_REWRITE_TAC[] THEN POP_ASSUM K_TAC THEN
+          FULL_SIMP_TAC real_ss[LN_EXP] THEN
+          FULL_SIMP_TAC real_ss[REAL_EQ_RMUL] THEN
+          KNOW_TAC``(1 < (a:real))==> 0 < ln a`` THENL[
+      RW_TAC real_ss [] THEN
+      KNOW_TAC``0 < ln a = exp (0) < exp (ln a)`` THEN1
+          PROVE_TAC[EXP_MONO_LT] THEN
+          DISCH_TAC THEN
+          FULL_SIMP_TAC real_ss[] THEN
+          RW_TAC real_ss [EXP_0] THEN
+              KNOW_TAC``1 < (a:real) ==> 0 <(a:real)`` THENL[
+                   RW_TAC real_ss [] THEN
+                   MATCH_MP_TAC REAL_LT_TRANS THEN
+                   EXISTS_TAC``(1:real)`` THEN
+                   RW_TAC real_ss [] ,
+                   RW_TAC real_ss [] THEN
+                   KNOW_TAC``exp (ln a)=(a:real)`` THEN1
+                      RW_TAC real_ss [EXP_LN] THEN
+       DISCH_TAC THEN ASM_REWRITE_TAC[] THEN  RW_TAC real_ss []],
+ FULL_SIMP_TAC real_ss[REAL_POS_NZ] ]);
+
+val  RPOW_DIV_BASE= store_thm
+        ("RPOW_DIV_BASE",
+        `` ! x t. (0 < x)==> ((x rpow t)/x = x rpow (t-1))``,
+RW_TAC std_ss [rpow, REAL_SUB_RDISTRIB, EXP_SUB, REAL_MUL_LID] THEN
+KNOW_TAC``exp(ln x)= (x:real)`` THEN1
+    PROVE_TAC[EXP_LN] THEN
+DISCH_TAC THEN ASM_REWRITE_TAC [] );
+
+(*----------------------------------------------------------------*)
+(* Differentiability of real powers                               *)
+(*----------------------------------------------------------------*)
+
+val  DIFF_COMPOSITE_EXP = store_thm
+        ("DIFF_COMPOSITE_EXP",
+        ``!g m x. ((g diffl m) x ==> ((\x. exp (g x)) diffl (exp (g x) * m)) x)``,
+       RW_TAC std_ss [DIFF_COMPOSITE]);
+
+val  DIFF_RPOW = store_thm
+        ("DIFF_RPOW",
+        ``!x y. 0 < x ==> (((\x. (x rpow y)) diffl (y* (x rpow (y-1))))x )``,
+RW_TAC real_ss [rpow,GSYM RPOW_DIV_BASE] THEN
+RW_TAC real_ss [REAL_MUL_ASSOC,real_div,REAL_MUL_COMM]THEN
+RW_TAC real_ss [GSYM real_div] THEN
+KNOW_TAC ``!x'. exp ((y * ln x')) = exp ((\x'. y *ln x') x')`` THEN1
+     RW_TAC real_ss [] THEN
+DISCH_TAC THEN ASM_REWRITE_TAC [] THEN POP_ASSUM K_TAC THEN
+KNOW_TAC `` ((y / x) * exp ((\x'. y * ln x') x))= ( exp ((\x'. y * ln x') x)*(y/x) ) `` THEN1
+     RW_TAC std_ss [REAL_MUL_COMM] THEN
+DISCH_TAC THEN ASM_REWRITE_TAC [] THEN POP_ASSUM K_TAC THEN
+MATCH_MP_TAC DIFF_COMPOSITE_EXP THEN
+KNOW_TAC ``((\x. y * ln x) diffl (y/x)) x = ((\x. y * (\x.ln x) x) diffl (y/x)) x`` THEN1
+     RW_TAC real_ss [] THEN
+DISCH_TAC THEN ASM_REWRITE_TAC [] THEN POP_ASSUM K_TAC THEN
+RW_TAC real_ss [real_div] THEN
+MATCH_MP_TAC DIFF_CMUL THEN
+MATCH_MP_TAC DIFF_LN THEN
+RW_TAC real_ss []);
+
+
 (*
 val MCLAURIN_LN_POS = store_thm("MCLAURIN_LN_POS",
  Term`!x n.


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 8859
          http://hol.svn.sourceforge.net/hol/?rev=8859&view=rev
Author:   michaeln
Date:     2011-01-14 00:39:26 +0000 (Fri, 14 Jan 2011)

Log Message:
-----------
Change src/bool to src/1 as a prelude to experimentation!

Modified Paths:
--------------
    HOL/tools/build-sequence

Added Paths:
-----------
    HOL/src/1/

Removed Paths:
-------------
    HOL/src/bool/

Modified: HOL/tools/build-sequence
===================================================================
--- HOL/tools/build-sequence	2011-01-13 00:11:27 UTC (rev 8858)
+++ HOL/tools/build-sequence	2011-01-14 00:39:26 UTC (rev 8859)
@@ -40,7 +40,7 @@
 src/postkernel
 # these three directories are required to even run hol.bare.unquote
 src/parse
-src/bool
+src/1
 src/proofman
 [poly]bin/hol.bare
 


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 8860
          http://hol.svn.sourceforge.net/hol/?rev=8860&view=rev
Author:   michaeln
Date:     2011-01-14 00:43:33 +0000 (Fri, 14 Jan 2011)

Log Message:
-----------
Move only primitive bool stuff into new src/bool.

Expectation is that *Map stuff will also leave this directory eventually.

Modified Paths:
--------------
    HOL/tools/build-sequence

Added Paths:
-----------
    HOL/src/bool/
    HOL/src/bool/OpenTheoryMap.sig
    HOL/src/bool/OpenTheoryMap.sml
    HOL/src/bool/TexTokenMap.sig
    HOL/src/bool/TexTokenMap.sml
    HOL/src/bool/boolScript.sml

Removed Paths:
-------------
    HOL/src/1/OpenTheoryMap.sig
    HOL/src/1/OpenTheoryMap.sml
    HOL/src/1/TexTokenMap.sig
    HOL/src/1/TexTokenMap.sml
    HOL/src/1/boolScript.sml

Deleted: HOL/src/1/OpenTheoryMap.sig
===================================================================
--- HOL/src/1/OpenTheoryMap.sig	2011-01-14 00:39:26 UTC (rev 8859)
+++ HOL/src/1/OpenTheoryMap.sig	2011-01-14 00:43:33 UTC (rev 8860)
@@ -1,19 +0,0 @@
-signature OpenTheoryMap =
-sig
-  structure Map : Redblackmap
-
-  type thy_tyop  = {Thy:string,Tyop:string}
-  type thy_const = {Thy:string,Name:string}
-  type 'a to_ot  = ('a,string) Map.dict
-  type 'a from_ot= (string,'a) Map.dict
-
-  val temp_OpenTheory_tyop_name  : {tyop :thy_tyop , name:string} -> unit
-  val temp_OpenTheory_const_name : {const:thy_const, name:string} -> unit
-  val OpenTheory_tyop_name  : {tyop :thy_tyop , name:string} -> unit
-  val OpenTheory_const_name : {const:thy_const, name:string} -> unit
-
-  val tyop_to_ot_map   : unit -> thy_tyop to_ot
-  val tyop_from_ot_map : unit -> thy_tyop from_ot
-  val const_to_ot_map  : unit -> thy_const to_ot
-  val const_from_ot_map: unit -> thy_const from_ot
-end

Deleted: HOL/src/1/OpenTheoryMap.sml
===================================================================
--- HOL/src/1/OpenTheoryMap.sml	2011-01-14 00:39:26 UTC (rev 8859)
+++ HOL/src/1/OpenTheoryMap.sml	2011-01-14 00:43:33 UTC (rev 8860)
@@ -1,90 +0,0 @@
-structure OpenTheoryMap :> OpenTheoryMap =
-struct
-  structure Map = Redblackmap
-  type thy_tyop  = {Thy:string,Tyop:string}
-  type thy_const = {Thy:string,Name:string}
-  type 'a to_ot  = ('a,string) Map.dict
-  type 'a from_ot= (string,'a) Map.dict
-  fun lex_cmp c (f1,f2) (x1,x2) =
-    case c(f1 x1,f1 x2) of EQUAL => c(f2 x1,f2 x2) | z => z
-  val thy_tyop_cmp : thy_tyop Lib.cmp  = lex_cmp String.compare (#Tyop,#Thy)
-  val thy_const_cmp : thy_const Lib.cmp = lex_cmp String.compare (#Name,#Thy)
-  val the_tyop_to_ot   = ref (Map.mkDict thy_tyop_cmp)
-  val the_tyop_from_ot = ref (Map.mkDict String.compare)
-  val the_const_to_ot  = ref (Map.mkDict thy_const_cmp)
-  val the_const_from_ot= ref (Map.mkDict String.compare)
-  fun tyop_to_ot_map()   = !the_tyop_to_ot
-  fun tyop_from_ot_map() = !the_tyop_from_ot
-  fun const_to_ot_map()  = !the_const_to_ot
-  fun const_from_ot_map()= !the_const_from_ot
-  type deltas = ({name:string,tyop : thy_tyop }list*
-                 {name:string,const: thy_const}list)
-  val read_deltas = let
-    open Coding infix >* infix >->
-    val r = StringData.reader
-    val r = (r >* (r >* r))
-    val r1 = many (map (fn (name,(Thy,Tyop)) => {name=name,tyop ={Thy=Thy,Tyop=Tyop}}) r)
-    val r2 = many (map (fn (name,(Thy,Name)) => {name=name,const={Thy=Thy,Name=Name}}) r)
-  in (r1 >-> literal " ") >* r2 end
-  fun write_deltas (l1,l2) = let
-    open Coding
-    val e = StringData.encode
-    fun f ({name,const={Thy,Name}},s) = String.concat[e name,e Thy,e Name,s]
-    val s2 = List.foldl f "" l2
-    fun f ({name,tyop ={Thy,Tyop}},s) = String.concat[e name,e Thy,e Tyop,s]
-  in List.foldl f (" "^s2) l1 end
-  val tyname = "OpenTheoryMap"
-  val (mk,dest) = Theory.LoadableThyData.new {thydataty = tyname,
-                                              merge = fn((a,b),(c,d))=>(c@...),
-                                              read = Coding.lift read_deltas,
-                                              write = write_deltas}
-  fun tyopToString  {Thy,Tyop} = "(Thy="^Thy^",Tyop="^Tyop^")"
-  fun constToString {Thy,Name} = "(Thy="^Thy^",Name="^Name^")"
-  fun temp_OpenTheory_tyop_name0 src {tyop,name} = let
-    val _ = case Map.peek(!the_tyop_to_ot,tyop) of NONE => ()
-            | SOME oldn =>
-              Feedback.HOL_WARNING "OpenTheoryMap" "OpenTheory_tyop_name"
-                (src^" overrides "^tyopToString tyop^
-                 " (was \""^oldn^"\"; now \""^name^"\"")
-  in
-    the_tyop_to_ot   := Map.insert(!the_tyop_to_ot  ,tyop,name);
-    the_tyop_from_ot := Map.insert(!the_tyop_from_ot,name,tyop)
-  end
-  val temp_OpenTheory_tyop_name = temp_OpenTheory_tyop_name0 "OpenTheory_tyop_name call"
-  fun temp_OpenTheory_const_name0 src {const,name} = let
-    val _ = case Map.peek(!the_const_to_ot,const) of NONE => ()
-            | SOME oldn =>
-              Feedback.HOL_WARNING "OpenTheoryMap" "OpenTheory_const_name"
-                (src^" overrides "^constToString const^
-                 " (was \""^oldn^"\"; now \""^name^"\"")
-  in
-    the_const_to_ot   := Map.insert(!the_const_to_ot  ,const,name);
-    the_const_from_ot := Map.insert(!the_const_from_ot,name,const)
-  end
-  val temp_OpenTheory_const_name = temp_OpenTheory_const_name0 "OpenTheory_const_name call"
-  fun OpenTheory_tyop_name r = let in
-    temp_OpenTheory_tyop_name r;
-    Theory.LoadableThyData.write_data_update {thydataty = tyname,
-                                              data = mk ([r],[])}
-  end
-  fun OpenTheory_const_name r = let in
-    temp_OpenTheory_const_name r;
-    Theory.LoadableThyData.write_data_update {thydataty = tyname,
-                                              data = mk ([],[r])}
-  end
-  fun onload thyname =
-    case Theory.LoadableThyData.segment_data {thy = thyname, thydataty = tyname} of
-      NONE => ()
-    | SOME t => let
-        val (l1,l2) = valOf (dest t)
-        handle Option => ([],[]) before
-                         Feedback.HOL_WARNING "OpenTheoryMap" "onload"
-                          ("Data for theory "^thyname^" appears corrupted.")
-        val src = "Theory "^thyname
-      in
-        List.app (temp_OpenTheory_tyop_name0  src) l1;
-        List.app (temp_OpenTheory_const_name0 src) l2
-      end
-  val _ = map onload (Theory.ancestry "-")
-  val _ = Theory.register_onload onload
-end

Deleted: HOL/src/1/TexTokenMap.sig
===================================================================
--- HOL/src/1/TexTokenMap.sig	2011-01-14 00:39:26 UTC (rev 8859)
+++ HOL/src/1/TexTokenMap.sig	2011-01-14 00:43:33 UTC (rev 8860)
@@ -1,9 +0,0 @@
-signature TexTokenMap =
-sig
-
-  val TeX_notation : {hol: string, TeX : string * int} -> unit
-  val temp_TeX_notation : {hol: string, TeX : string * int} -> unit
-
-  val the_map : unit -> (string,string * int)Binarymap.dict
-
-end

Deleted: HOL/src/1/TexTokenMap.sml
===================================================================
--- HOL/src/1/TexTokenMap.sml	2011-01-14 00:39:26 UTC (rev 8859)
+++ HOL/src/1/TexTokenMap.sml	2011-01-14 00:43:33 UTC (rev 8860)
@@ -1,83 +0,0 @@
-structure TexTokenMap :> TexTokenMap =
-struct
-
-  open HolKernel
-  type deltas = {hol:string,TeX:string*int} list
-
-  val read_deltas = let
-    open Coding
-    infix >*
-  in
-    many (map (fn (s1,(s2,i)) => {hol=s1,TeX=(s2,i)})
-              (StringData.reader >* (StringData.reader >* IntData.reader)))
-  end
-
-  fun write_deltas dlist = let
-    open Coding
-    val enc = StringData.encode
-    val ienc = IntData.encode
-    fun recurse acc dlist =
-      case dlist of
-        [] => String.concat (List.rev acc)
-      | {hol,TeX=(s,i)}::t => recurse (ienc i :: enc s :: enc hol :: acc) t
-  in
-    recurse [] dlist
-  end
-  val tyname = "TexTokenMap"
-
-  val (mk,dest) = Theory.LoadableThyData.new {thydataty = tyname,
-                                              merge = op@,
-                                              read = Coding.lift read_deltas,
-                                              write = write_deltas}
-
-
-  val tokmap = ref (Binarymap.mkDict String.compare)
-  fun the_map() = !tokmap
-
-  fun temp_TeX_notation0 src {hol,TeX} =
-      case Binarymap.peek (!tokmap, hol) of
-        NONE => tokmap := Binarymap.insert(!tokmap,hol,TeX)
-      | SOME oldt => let
-          fun ttoString (t,i) = "(\"" ^ String.toString t ^ "\", "^
-                                Int.toString i ^ ")"
-        in
-          HOL_WARNING "TexTokenMap" "TeX_notation"
-                      (src^" overrides \""^
-                       String.toString hol^"\" (was \""^
-                       ttoString oldt^"\"); now \""^
-                       ttoString TeX^"\"");
-          tokmap := Binarymap.insert(!tokmap,hol,TeX)
-        end
-
-  val temp_TeX_notation = temp_TeX_notation0 "TeX_notation call"
-
-  fun TeX_notation record = let
-  in
-    temp_TeX_notation record;
-    Theory.LoadableThyData.write_data_update {thydataty = tyname,
-                                              data = mk [record]}
-  end
-
-
-  fun onload thyname = let
-    open Theory
-  in
-    case LoadableThyData.segment_data {thy = thyname, thydataty = tyname} of
-      NONE => ()
-    | SOME t => let
-        open Feedback
-        val deltas = valOf (dest t)
-            handle Option => (HOL_WARNING "TexTokenMap" "onload"
-                                          ("Data for theory "^thyname^
-                                           " appears corrupted.");
-                              [])
-      in
-        List.app (temp_TeX_notation0 ("Theory "^thyname)) deltas
-      end
-  end
-
-  val _ = map onload (ancestry "-")
-
-  val _ = Theory.register_onload onload
-
-end (* struct *)

Deleted: HOL/src/1/boolScript.sml
===================================================================
--- HOL/src/1/boolScript.sml	2011-01-14 00:39:26 UTC (rev 8859)
+++ HOL/src/1/boolScript.sml	2011-01-14 00:43:33 UTC (rev 8860)
@@ -1,4559 +0,0 @@
-(* ===================================================================== *)
-(* FILE          : boolScript.sml                                        *)
-(* DESCRIPTION   : Definition of the logical constants and assertion of  *)
-(*                 the axioms.                                           *)
-(* AUTHORS       : (c) Mike Gordon, University of Cambridge              *)
-(*                 Tom Melham, Richard Boulton, John Harrison,           *)
-(*                 Konrad Slind, Michael Norrish, Jim Grundy, Joe Hurd   *)
-(*                 and probably others that don't immediately come to    *)
-(*                 mind.                                                 *)
-(* ===================================================================== *)
-
-structure boolScript =
-struct
-
-open HolKernel Parse
-open Unicode TexTokenMap OpenTheoryMap
-
-val _ = new_theory "bool";
-
-(*---------------------------------------------------------------------------*
- *             BASIC DEFINITIONS                                             *
- *---------------------------------------------------------------------------*)
-
-(* parsing/printing support for theory min *)
-val _ = OpenTheory_const_name {const={Thy="min",Name="="},name="="}
-val _ = OpenTheory_tyop_name {tyop={Thy="min",Tyop="fun"},name="->"}
-val _ = OpenTheory_tyop_name {tyop={Thy="min",Tyop="bool"},name="bool"}
-
-val _ = unicode_version {u = UChar.imp, tmnm = "==>"}
-val _ = TeX_notation {hol = "==>", TeX = ("\\HOLTokenImp{}", 1)}
-val _ = TeX_notation {hol = UChar.imp, TeX = ("\\HOLTokenImp{}", 1)}
-val _ = OpenTheory_const_name {const={Thy="min",Name="==>"},name="Data.Bool.==>"}
-
-val _ = TeX_notation {hol = "\\", TeX = ("\\HOLTokenLambda{}", 1)}
-val _ = TeX_notation {hol = UChar.lambda, TeX = ("\\HOLTokenLambda{}", 1)}
-
-val _ = TeX_notation {hol = "@", TeX = ("\\HOLTokenHilbert{}", 1)}
-val _ = OpenTheory_const_name {const={Thy="min",Name="@"},name="Data.Bool.select"}
-
-(* records *)
-val _ = TeX_notation {hol = "<|", TeX = ("\\HOLTokenLeftrec{}", 2)}
-val _ = TeX_notation {hol = "|>", TeX = ("\\HOLTokenRightrec{}", 2)}
-
-(* case expressions *)
-val _ = TeX_notation {hol = "case", TeX = ("\\HOLKeyword{case}", 4)}
-val _ = TeX_notation {hol = "of",   TeX = ("\\HOLKeyword{of}", 2)}
-val _ = TeX_notation {hol = "->", TeX = ("\\HOLTokenMap{}", 1)}
-val _ = TeX_notation {hol = "||", TeX = ("\\HOLTokenOr{} ", 2)}
-
-(* let expressions *)
-val _ = TeX_notation {hol = "let", TeX = ("\\HOLKeyword{let}", 3)}
-val _ = TeX_notation {hol = "and", TeX = ("\\HOLKeyword{and}", 2)}
-val _ = TeX_notation {hol = "in",  TeX = ("\\HOLKeyword{in}", 2)}
-
-(* if statements *)
-val _ = TeX_notation {hol = "if",   TeX = ("\\HOLKeyword{if}", 2)}
-val _ = TeX_notation {hol = "then", TeX = ("\\HOLKeyword{then}", 4)}
-val _ = TeX_notation {hol = "else", TeX = ("\\HOLKeyword{else}", 4)}
-
-
-val T_DEF =
- Definition.new_definition
-   ("T_DEF",          Term `T = ((\x:bool. x) = \x:bool. x)`);
-
-val _ = add_const "T";
-val _ = OpenTheory_const_name {const={Thy="bool",Name="T"},name="Data.Bool.T"}
-
-val FORALL_DEF =
- Definition.new_definition
-   ("FORALL_DEF",     Term `! = \P:'a->bool. P = \x. T`);
-
-val _ = (set_fixity "!" Binder; add_const "!");
-val _ = unicode_version {u = UChar.forall, tmnm = "!"};
-val _ = TeX_notation {hol = "!", TeX = ("\\HOLTokenForall{}",1)}
-val _ = TeX_notation {hol = UChar.forall, TeX = ("\\HOLTokenForall{}",1)}
-val _ = OpenTheory_const_name {const={Thy="bool",Name="!"},name="Data.Bool.!"}
-
-val EXISTS_DEF =
- Definition.new_definition
-   ("EXISTS_DEF",     Term `? = \P:'a->bool. P ($@ P)`);
-
-val _ = (set_fixity "?" Binder; add_const "?");
-val _ = unicode_version {u = UChar.exists, tmnm = "?"}
-val _ = TeX_notation {hol = "?", TeX = ("\\HOLTokenExists{}",1)}
-val _ = TeX_notation {hol = UChar.exists, TeX = ("\\HOLTokenExists{}",1)}
-val _ = OpenTheory_const_name {const={Thy="bool",Name="?"},name="Data.Bool.?"}
-
-val AND_DEF =
- Definition.new_definition
-   ("AND_DEF",        Term `/\ = \t1 t2. !t. (t1 ==> t2 ==> t) ==> t`);
-
-val _ = (add_infix ("/\\", 400, RIGHT); add_const "/\\");
-val _ = unicode_version {u = UChar.conj, tmnm = "/\\"};
-val _ = TeX_notation {hol = "/\\", TeX = ("\\HOLTokenConj{}",1)}
-val _ = TeX_notation {hol = UChar.conj, TeX = ("\\HOLTokenConj{}",1)}
-val _ = OpenTheory_const_name {const={Thy="bool",Name="/\\"},name="Data.Bool./\\\\"}
-
-
-val OR_DEF =
- Definition.new_definition
-   ("OR_DEF",         Term `\/ = \t1 t2. !t. (t1 ==> t) ==> (t2 ==> t) ==> t`)
-
-val _ = (add_infix ("\\/", 300, RIGHT); add_const "\\/");
-val _ = unicode_version {u = UChar.disj, tmnm = "\\/"}
-val _ = TeX_notation {hol = "\\/", TeX = ("\\HOLTokenDisj{}",1)}
-val _ = TeX_notation {hol = UChar.disj, TeX = ("\\HOLTokenDisj{}",1)}
-val _ = OpenTheory_const_name {const={Thy="bool",Name="\\/"},name="Data.Bool.\\\\/"}
-
-
-val F_DEF =
- Definition.new_definition
-   ("F_DEF",          Term `F = !t. t`);
-
-val _ = Parse.add_const "F";
-val _ = OpenTheory_const_name {const={Thy="bool",Name="F"},name="Data.Bool.F"}
-
-val NOT_DEF =
- Definition.new_definition
-   ("NOT_DEF",        Term `~ = \t. t ==> F`);
-
-val _ = add_const "~";
-
-val EXISTS_UNIQUE_DEF =
-Definition.new_definition
-("EXISTS_UNIQUE_DEF", Term `?! = \P:'a->bool.
-                                    $? P /\ !x y. P x /\ P y ==> (x=y)`);
-
-val _ = (set_fixity "?!" Binder; add_const "?!")
-
-val _ = unicode_version { u = UChar.exists ^ "!", tmnm = "?!"}
-val _ = TeX_notation {hol = "?!", TeX = ("\\HOLTokenUnique{}",2)}
-val _ = TeX_notation {hol = UChar.exists ^ "!", TeX = ("\\HOLTokenUnique{}",2)}
-
-val LET_DEF =
- Definition.new_definition
-   ("LET_DEF",        Term `LET = \(f:'a->'b) x. f x`);
-
-val _ = add_const "LET";
-
-val COND_DEF =
- Definition.new_definition
-   ("COND_DEF",       Term `COND = \t t1 t2.
-                                      @x:'a. ((t=T) ==> (x=t1)) /\
-                                             ((t=F) ==> (x=t2))`);
-val _ = add_const "COND";
-
-val ONE_ONE_DEF =
- Definition.new_definition
-   ("ONE_ONE_DEF",    Term `ONE_ONE = \f:'a->'b. !x1 x2.
-                                         (f x1 = f x2) ==> (x1 = x2)`);
-
-val _ = add_const "ONE_ONE";
-
-val ONTO_DEF =
- Definition.new_definition
-   ("ONTO_DEF",       Term `ONTO = \f:'a->'b. !y. ?x. y = f x`);
-
-val _ = add_const "ONTO";
-
-val TYPE_DEFINITION =
- Definition.new_definition
-   ("TYPE_DEFINITION",
-                      Term `TYPE_DEFINITION = \P:'a->bool. \rep:'b->'a.
-                              (!x' x''. (rep x' = rep x'') ==> (x' = x'')) /\
-                              (!x. P x = (?x'. x = rep x'))`);
-
-val _ = add_const "TYPE_DEFINITION";
-
-
-(*---------------------------------------------------------------------------*
- *   Parsing directives for some of the basic operators.                     *
- *---------------------------------------------------------------------------*)
-
-open Portable;
-val _ = add_rule {term_name   = "~",
-                  fixity      = TruePrefix 900,
-                  pp_elements = [TOK "~"],
-                  paren_style = OnlyIfNecessary,
-                  block_style = (AroundEachPhrase, (CONSISTENT, 0))};
-val _ = unicode_version { u = UChar.neg, tmnm = "~"};
-val _ = TeX_notation {hol = "~", TeX = ("\\HOLTokenNeg{}",1)}
-val _ = TeX_notation {hol = UChar.neg, TeX = ("\\HOLTokenNeg{}",1)}
-
-(* prettyprinting information here for "let" and "and" is completely ignored;
-   the pretty-printer handles these specially.  These declarations are only
-   for the parser's benefit. *)
-val _ = add_rule {term_name   = GrammarSpecials.let_special,
-                  fixity = TruePrefix 2,
-                  pp_elements = [TOK "let", BreakSpace(1,0), TM,
-                                 BreakSpace(1, 0), TOK "in",
-                                 BreakSpace(1, 0)],
-                  paren_style = OnlyIfNecessary,
-                  block_style = (AroundEachPhrase, (INCONSISTENT, 0))};
-
-val _ = add_rule {term_name = GrammarSpecials.and_special,
-                  fixity = Infixl 9,
-                  pp_elements = [TOK "and"],
-                  paren_style = OnlyIfNecessary,
-                  block_style = (AroundEachPhrase, (INCONSISTENT, 0))}
-
-val _ = add_rule{term_name   = "COND",
-                 fixity      = TruePrefix 70,
-                 pp_elements = [PPBlock([TOK "if", BreakSpace(1,2), TM,
-                                         BreakSpace(1,0),
-                                         TOK "then"], (CONSISTENT, 0)),
-                                BreakSpace(1,2), TM, BreakSpace(1,0),
-                                TOK "else", BreakSpace(1,2)],
-                 paren_style = OnlyIfNecessary,
-                 block_style = (AroundEachPhrase, (CONSISTENT, 0))};
-
-
-(*---------------------------------------------------------------------------*
- *                   AXIOMS                                                  *
- *                                                                           *
- * Bruno Barras noticed that the axiom IMP_ANTISYM_AX from the original      *
- * HOL logic was provable.                                                   *
- *---------------------------------------------------------------------------*)
-
-val BOOL_CASES_AX =
- new_axiom
-   ("BOOL_CASES_AX", Term `!t. (t=T) \/ (t=F)`);
-
-val ETA_AX =
- new_axiom
-   ("ETA_AX",        Term `!t:'a->'b. (\x. t x) = t`);
-
-val SELECT_AX =
- new_axiom
-   ("SELECT_AX",     Term `!(P:'a->bool) x. P x ==> P ($@ P)`);
-
-val INFINITY_AX =
- new_axiom
-   ("INFINITY_AX",   Term `?f:ind->ind. ONE_ONE f /\ ~ONTO f`);
-
-
-(*---------------------------------------------------------------------------*
- * Miscellaneous utility definitions, of use in some packages.               *
- *---------------------------------------------------------------------------*)
-
-val arb = new_constant("ARB",alpha);  (* Doesn't have to be defined at all. *)
-
-val bool_case_DEF =
- Definition.new_definition
-   ("bool_case_DEF",  Term `bool_case = \(x:'a) y b. COND b x y`);
-
-val literal_case_DEF =
- Definition.new_definition
-   ("literal_case_DEF",  Term `literal_case = \(f:'a->'b) x. f x`);
-
-val _ = List.app add_const ["ARB", "bool_case", "literal_case"];
-val _ = overload_on ("case", ``bool$literal_case``);
-
-val IN_DEF =
- Definition.new_definition
-   ("IN_DEF",         Term `IN = \x (f:'a->bool). f x`);
-
-val _ = (add_infix ("IN", 425, Parse.NONASSOC); add_const "IN");
-val _ = unicode_version {u = UChar.setelementof, tmnm = "IN"};
-val _ = TeX_notation {hol = "IN", TeX = ("\\HOLTokenIn{}",1)}
-val _ = TeX_notation {hol = UChar.setelementof, TeX = ("\\HOLTokenIn{}",1)}
-
-val RES_FORALL_DEF =
- Definition.new_definition
-   ("RES_FORALL_DEF", Term `RES_FORALL = \p m. !x : 'a. x IN p ==> m x`);
-
-val _ = (add_const "RES_FORALL"; associate_restriction ("!",  "RES_FORALL"));
-
-val RES_EXISTS_DEF =
- Definition.new_definition
-   ("RES_EXISTS_DEF", Term `RES_EXISTS = \p m. ?x : 'a. x IN p /\ m x`);
-
-val _ = (add_const "RES_EXISTS"; associate_restriction ("?",  "RES_EXISTS"));
-
-val RES_EXISTS_UNIQUE_DEF =
- Definition.new_definition
-   ("RES_EXISTS_UNIQUE_DEF",
-    Term `RES_EXISTS_UNIQUE =
-          \p m. (?(x : 'a) :: p. m x) /\ !x y :: p. m x /\ m y ==> (x = y)`);
-
-val _ = add_const "RES_EXISTS_UNIQUE";
-val _ = associate_restriction ("?!",  "RES_EXISTS_UNIQUE");
-
-val RES_SELECT_DEF =
- Definition.new_definition
-   ("RES_SELECT_DEF", Term `RES_SELECT = \p m. @x : 'a. x IN p /\ m x`);
-
-val _ = (add_const "RES_SELECT"; associate_restriction ("@",  "RES_SELECT"));
-
-(* Note: RES_ABSTRACT comes later, defined by new_specification *)
-
-(*---------------------------------------------------------------------------*)
-(* Experimental rewriting directives                                         *)
-(*---------------------------------------------------------------------------*)
-
-val BOUNDED_DEF =
-  Definition.new_definition
-    ("BOUNDED_DEF",
-     Term `BOUNDED = \(v:bool). T`);
-
-
-(*---------------------------------------------------------------------------*)
-(* Support for detecting datatypes in theory files                           *)
-(*---------------------------------------------------------------------------*)
-
-val DATATYPE_TAG_DEF =
-  Definition.new_definition
-    ("DATATYPE_TAG_DEF",
-     Term`DATATYPE = \x. T`);
-
-val _ = List.app add_const ["BOUNDED", "DATATYPE"];
-
-(*---------------------------------------------------------------------------*
- *                   THEOREMS                                                *
- *---------------------------------------------------------------------------*)
-
-val op --> = Type.-->
-infix ## |->;
-
-val ERR = Feedback.mk_HOL_ERR "boolScript"
-
-val F = Term`F`
-val T = Term`T`;
-val implication = prim_mk_const{Name="==>", Thy="min"}
-val select      = prim_mk_const{Name="@",   Thy="min"}
-val conjunction = prim_mk_const{Name="/\\", Thy="bool"}
-val disjunction = prim_mk_const{Name="\\/", Thy="bool"}
-val negation    = prim_mk_const{Name="~",   Thy="bool"}
-val universal   = prim_mk_const{Name="!",   Thy="bool"}
-val existential = prim_mk_const{Name="?",   Thy="bool"}
-val exists1     = prim_mk_const{Name="?!",  Thy="bool"}
-val in_tm       = prim_mk_const{Name="IN",  Thy="bool"};
-
-
-val dest_neg    = sdest_monop("~","bool")   (ERR"dest_neg" "");
-val dest_eq     = sdest_binop("=","min")    (ERR"dest_eq" "");
-val dest_disj   = sdest_binop("\\/","bool") (ERR"dest_disj" "");
-val dest_conj   = sdest_binop("/\\","bool") (ERR"dest_conj" "");
-val dest_forall = sdest_binder("!","bool")  (ERR"dest_forall" "");
-val dest_exists = sdest_binder("?","bool")  (ERR"dest_exists" "");
-fun strip_forall fm =
-   if can dest_forall fm
-   then let val (Bvar,Body) = dest_forall fm
-            val (bvs,core) = strip_forall Body
-        in ((Bvar::bvs), core)
-        end
-   else ([],fm);
-val lhs = fst o dest_eq;
-val rhs = snd o dest_eq;
-
-
-local val imp = Term`$==>`  val notc = Term`$~`
-in
-fun dest_imp M =
- let val (Rator,conseq) = dest_comb M
- in if is_comb Rator
-    then let val (Rator,ant) = dest_comb Rator
-         in if Rator=imp then (ant,conseq)
-            else raise Fail "dest_imp"
-         end
-    else if Rator=notc then (conseq,F) else raise Fail "dest_imp"
- end
-end
-
-fun mk_neg M              = Term `~^M`;
-fun mk_eq(lhs,rhs)        = Term `^lhs = ^rhs`;
-fun mk_imp(ant,conseq)    = Term `^ant ==> ^conseq`;
-fun mk_conj(conj1,conj2)  = Term `^conj1 /\ ^conj2`;
-fun mk_disj(disj1,disj2)  = Term `^disj1 \/ ^disj2`;
-fun mk_forall(Bvar,Body)  = Term `!^Bvar. ^Body`
-fun mk_exists(Bvar,Body)  = Term `?^Bvar. ^Body`
-fun mk_exists1(Bvar,Body) = Term `?!^Bvar. ^Body`
-
-val list_mk_forall = itlist (curry mk_forall)
-val list_mk_exists = itlist (curry mk_exists)
-
-(* also implemented in Drule *)
-fun ETA_CONV t =
-  let val (var, cmb) = dest_abs t
-      val tysubst = [alpha |-> type_of var, beta |-> type_of cmb]
-      val th = SPEC (rator cmb) (INST_TYPE tysubst ETA_AX)
-  in
-    TRANS (ALPHA t (lhs (concl th))) th
-  end;
-
-fun EXT th =
-   let val (Bvar,_) = dest_forall(concl th)
-       val th1 = SPEC Bvar th
-       val (t1x, t2x) = dest_eq(concl th1)
-       val x = rand t1x
-       val th2 = ABS x th1
-   in
-   TRANS (TRANS(SYM(ETA_CONV (mk_abs(x, t1x)))) th2)
-         (ETA_CONV (mk_abs(x,t2x)))
-   end;
-
-fun DISCH_ALL th = DISCH_ALL (DISCH (hd (hyp th)) th) handle _ => th;
-
-fun PROVE_HYP ath bth = MP (DISCH (concl ath) bth) ath;
-
-fun CONV_RULE conv th = EQ_MP (conv(concl th)) th;
-
-fun RAND_CONV conv tm =
-   let val (Rator,Rand) = dest_comb tm
-   in AP_TERM Rator (conv Rand)
-   end;
-
-fun RATOR_CONV conv tm =
-   let val (Rator,Rand) = dest_comb tm in AP_THM (conv Rator) Rand end;
-
-fun ABS_CONV conv tm =
-   let val (Bvar,Body) = dest_abs tm in ABS Bvar (conv Body) end;
-
-fun QUANT_CONV conv = RAND_CONV(ABS_CONV conv);
-
-fun RIGHT_BETA th = TRANS th (BETA_CONV(snd(dest_eq(concl th))));
-
-fun UNDISCH th = MP th (ASSUME(fst(dest_imp(concl th))));
-
-fun FALSITY_CONV tm = DISCH F (SPEC tm (EQ_MP F_DEF (ASSUME F)))
-
-fun UNFOLD_OR_CONV tm =
-  let val (disj1,disj2) = dest_disj tm in
-  RIGHT_BETA(AP_THM (RIGHT_BETA(AP_THM OR_DEF disj1)) disj2)
-  end;
-
-(*---------------------------------------------------------------------------
- *  |- T
- *---------------------------------------------------------------------------*)
-
-val TRUTH = EQ_MP (SYM T_DEF) (REFL (--`\x:bool. x`--));
-val _ = save_thm("TRUTH",TRUTH);
-
-fun EQT_ELIM th = EQ_MP (SYM th) TRUTH;
-
-(* SPEC could be built here. *)
-(* GEN could be built here. *)
-
-(* auxiliary functions to do bool case splitting *)
-(* maps thm  |- P[x\t]  to  |- y=t ==> P[x\y] *)
-fun CUT_EQUAL P x y t thm =
-  let val e = mk_eq(y,t) in
-  DISCH e (SUBST [(x|->SYM (ASSUME e))] P thm)
-  end;
-
-(* given proofs of P[x\T] and P[x\F], proves P[x\t] *)
-fun BOOL_CASE P x t pt pf =
-  let val th0 = SPEC t BOOL_CASES_AX
-      val th1 = EQ_MP (UNFOLD_OR_CONV (concl th0)) th0
-      val th2 = SPEC (subst[(x|->t)] P) th1 in
-  MP (MP th2 (CUT_EQUAL P x t (--`T`--) pt)) (CUT_EQUAL P x t (--`F`--) pf)
-  end;
-
-fun EQT_INTRO th =
-   let val t = concl th
-       val x = genvar bool
-   in
-   BOOL_CASE (--`^x=T`--) x t (REFL T)
-     (MP (FALSITY_CONV (--`F=T`--)) (EQ_MP (ASSUME(--`^t=F`--)) th))
-   end;
-
-(*---------------------------------------------------------------------------
- * |- !t1 t2. (t1 ==> t2) ==> (t2 ==> t1) ==> (t1 = t2)
- *---------------------------------------------------------------------------*)
-
-val IMP_ANTISYM_AX =
- let val t1 = --`t1:bool`--
-     val t2 = --`t2:bool`--
-     fun dsch t1 t2 th = DISCH (--`^t2 ==> ^t1`--)
-                           (DISCH (--`^t1 ==> ^t2`--) th)
-      fun sch t1 t2 = --`(^t1==>^t2) ==> (^t2==>^t1) ==> (^t1=^t2)`--
-      val abs = MP (FALSITY_CONV (--`F=T`--)) (MP (ASSUME (--`T==>F`--)) TRUTH)
-      val tht = BOOL_CASE (sch T t2) t2 t2
-                          (dsch T T (REFL T)) (dsch F T (SYM abs))
-      val thf = BOOL_CASE (sch F t2) t2 t2
-                          (dsch T F abs) (dsch F F (REFL F))
- in
-   GEN t1 (GEN t2 (BOOL_CASE (sch t1 t2) t1 t1 tht thf))
- end;
-
-val _ = save_thm("IMP_ANTISYM_AX",IMP_ANTISYM_AX);
-
-fun IMP_ANTISYM_RULE th1 th2 =
-  let val (ant,conseq) = dest_imp(concl th1)
-  in
-     MP (MP (SPEC conseq (SPEC ant IMP_ANTISYM_AX)) th1) th2
-  end;
-
-
-(*---------------------------------------------------------------------------
- * |- !t. F ==> t
- *---------------------------------------------------------------------------*)
-
-val FALSITY = let val t = Term`t:bool` in GEN t (FALSITY_CONV t) end;
-val _ = save_thm("FALSITY", FALSITY);
-
-fun CONTR tm th = MP (SPEC tm FALSITY) th
-
-fun DISJ_IMP dth =
-   let val (disj1,disj2) = dest_disj (concl dth)
-       val nota = mk_neg disj1
-   in
-     DISCH nota
-      (DISJ_CASES dth
-         (CONTR disj2 (MP (ASSUME nota) (ASSUME disj1)))
-         (ASSUME disj2))
-   end
-
-fun EQF_INTRO th = IMP_ANTISYM_RULE (NOT_ELIM th)
-        (DISCH (Term`F`) (CONTR (dest_neg (concl th)) (ASSUME (Term`F`))));
-
-fun SELECT_EQ x =
- let val ty = type_of x
-     val choose = mk_const("@", (ty --> Type.bool) --> ty)
- in
-  fn th => AP_TERM choose (ABS x th)
- end
-
-fun GENL varl thm = itlist GEN varl thm;
-
-fun SPECL tm_list th = rev_itlist SPEC tm_list th
-
-fun GEN_ALL th = itlist GEN (set_diff (free_vars(concl th))
-                                      (free_varsl (hyp th))) th;
-
-local fun f v (vs,l) = let val v' = variant vs v in (v'::vs, v'::l) end
-in
-fun SPEC_ALL th =
-   let val (hvs,con) = (free_varsl ## I) (hyp th, concl th)
-       val fvs = free_vars con
-       and vars = fst(strip_forall con)
-   in
-     SPECL (snd(itlist f vars (hvs@...,[]))) th
-   end
-end;
-
-fun SUBST_CONV theta template tm =
-  let fun retheta {redex,residue} = (redex |-> genvar(type_of redex))
-      val theta0 = map retheta theta
-      val theta1 = map (op |-> o (#residue ## #residue)) (zip theta0 theta)
-  in
-   SUBST theta1 (mk_eq(tm,subst theta0 template)) (REFL tm)
-  end;
-
-local fun combine [] [] = []
-        | combine (v::rst1) (t::rst2) = (v |-> t) :: combine rst1 rst2
-        | combine _ _ = raise Fail "SUBS"
-in
-fun SUBS ths th =
-   let val ls = map (lhs o concl) ths
-       val vars = map (genvar o type_of) ls
-       val w = subst (combine ls vars) (concl th)
-   in
-     SUBST (combine vars ths) w th
-   end
-end;
-
-fun IMP_TRANS th1 th2 =
-   let val (ant,conseq) = dest_imp(concl th1)
-   in DISCH ant (MP th2 (MP th1 (ASSUME ant))) end;
-
-fun ADD_ASSUM t th = MP (DISCH t th) (ASSUME t);
-
-fun SPEC_VAR th =
-   let val (Bvar,_) = dest_forall (concl th)
-       val bv' = variant (free_varsl (hyp th)) Bvar
-   in (bv', SPEC bv' th)
-   end;
-
-fun MK_EXISTS bodyth =
-   let val (x, sth) = SPEC_VAR bodyth
-       val (a,b) = dest_eq (concl sth)
-       val (abimp,baimp) = EQ_IMP_RULE sth
-       fun HALF (p,q) pqimp =
-          let val xp = mk_exists(x,p)
-              and xq = mk_exists(x,q)
-          in DISCH xp
-              (CHOOSE (x, ASSUME xp) (EXISTS (xq,x) (MP pqimp (ASSUME p))))
-          end
-   in
-     IMP_ANTISYM_RULE (HALF (a,b) abimp) (HALF (b,a) baimp)
-   end;
-
-fun SELECT_RULE th =
-  let val (tm as (Bvar, Body)) = dest_exists(concl th)
-      val v = genvar(type_of Bvar)
-      val P = mk_abs tm
-      val SELECT_AX' = INST_TYPE[alpha |-> type_of Bvar] SELECT_AX
-      val th1 = SPEC v (SPEC P SELECT_AX')
-      val (ant,conseq) = dest_imp(concl th1)
-      val th2 = BETA_CONV ant
-      and th3 = BETA_CONV conseq
-      val th4 = EQ_MP th3 (MP th1 (EQ_MP(SYM th2) (ASSUME (rhs(concl th2)))))
-  in
-     CHOOSE (v,th) th4
-  end;
-
-
-(*---------------------------------------------------------------------------
-     ETA_THM = |- !M. (\x. M x) = M
- ---------------------------------------------------------------------------*)
-
-val ETA_THM = GEN_ALL(ETA_CONV (Term`\x:'a. (M x:'b)`));
-val _ = save_thm("ETA_THM",ETA_THM);
-
-(*---------------------------------------------------------------------------
- *  |- !t. t \/ ~t
- *---------------------------------------------------------------------------*)
-
-val EXCLUDED_MIDDLE =
-   let val t = --`t:bool`--
-       val th1 = RIGHT_BETA(AP_THM NOT_DEF t)
-       val th2 = DISJ1 (EQT_ELIM(ASSUME (--`^t = T`--))) (--`~^t`--)
-       and th3 = DISJ2 t (EQ_MP (SYM th1)
-                                (DISCH t (EQ_MP (ASSUME (--`^t = F`--))
-                                                (ASSUME t))))
-   in
-      GEN t (DISJ_CASES (SPEC t BOOL_CASES_AX) th2 th3)
-   end;
-
-val _ = save_thm("EXCLUDED_MIDDLE",EXCLUDED_MIDDLE);
-
-fun IMP_ELIM th =
-  let val (ant,conseq) = dest_imp (concl th)
-       val not_t1 = mk_neg ant
-  in
-   DISJ_CASES (SPEC ant EXCLUDED_MIDDLE)
-              (DISJ2 not_t1 (MP th (ASSUME ant)))
-              (DISJ1 (ASSUME not_t1) conseq)
-  end;
-
-(*---------------------------------------------------------------------------*
- *  |- !f y. (\x. f x) y = f y                                               *
- *---------------------------------------------------------------------------*)
-
-val BETA_THM =
-   GENL [Term`f:'a->'b`, Term `y:'a`]
-        (BETA_CONV (Term`(\x. (f:'a->'b) x) y`));
-
-val _ = save_thm("BETA_THM", BETA_THM);
-
-(*---------------------------------------------------------------------------
-     LET_THM = |- !f x. LET f x = f x
- ---------------------------------------------------------------------------*)
-
-val LET_THM =
- let val f = Term `f:'a->'b`
-     val x = Term `x:'a`
- in
-  GEN f (GEN x
-    (RIGHT_BETA(AP_THM (RIGHT_BETA(AP_THM LET_DEF f)) x)))
- end;
-
-val _ = save_thm("LET_THM", LET_THM);
-
-
-val FORALL_THM =
-  SYM (AP_TERM (Term `$! :('a->bool)->bool`)
-               (ETA_CONV (Term `\x:'a. f x:bool`)));
-
-val EXISTS_THM =
-  SYM (AP_TERM (Term `$? :('a->bool)->bool`)
-               (ETA_CONV (Term `\x:'a. f x:bool`)));
-
-val _ = save_thm("FORALL_THM",FORALL_THM);
-val _ = save_thm("EXISTS_THM",EXISTS_THM);
-
-(*---------------------------------------------------------------------------*
- *  |- !t1:'a. !t2:'b. (\x. t1) t2 = t1                                      *
- *---------------------------------------------------------------------------*)
-
-val ABS_SIMP =
-   GENL [Term`t1:'a`, Term `t2:'b`]
-        (BETA_CONV (Term`(\x:'b. t1:'a) t2`));
-
-val _ = save_thm("ABS_SIMP", ABS_SIMP);
-
-(*---------------------------------------------------------------------------
- *   |- !t. (!x.t)  =  t
- *---------------------------------------------------------------------------*)
-
-val FORALL_SIMP =
- let val t = --`t:bool`--
-     val x = --`x:'a`--
- in
- GEN t (IMP_ANTISYM_RULE
-        (DISCH (--`!^x.^t`--) (SPEC x (ASSUME (--`!^x.^t`--))))
-        (DISCH t (GEN x (ASSUME t))))
- end;
-
-val _ = save_thm("FORALL_SIMP", FORALL_SIMP);
-
-(*---------------------------------------------------------------------------
- *   |- !t. (?x.t)  =  t
- *---------------------------------------------------------------------------*)
-
-val EXISTS_SIMP =
-   let val t = --`t:bool`--
-       and x = --`x:'a`--
-       val ext = --`?^x.^t`--
-   in
-   GEN t (IMP_ANTISYM_RULE
-           (DISCH ext (CHOOSE((--`p:'a`--), ASSUME ext) (ASSUME t)))
-           (DISCH t (EXISTS(ext, --`r:'a`--) (ASSUME t))))
-   end;
-
-val _ = save_thm("EXISTS_SIMP", EXISTS_SIMP);
-
-
-(*---------------------------------------------------------------------------
- *       |- !t1 t2. t1 ==> t2 ==> t1 /\ t2
- *---------------------------------------------------------------------------*)
-
-val AND_INTRO_THM =
-   let val t = --`t:bool`--
-       and t1 = --`t1:bool`--
-       and t2 = --`t2:bool`--
-       val t12 = --`^t1 ==> (^t2 ==> ^t)`--
-       val th1 = GEN t (DISCH t12 (MP (MP (ASSUME t12)
-                                          (ASSUME t1))
-                                      (ASSUME t2)))
-       val th2 = RIGHT_BETA(AP_THM (RIGHT_BETA(AP_THM AND_DEF t1)) t2)
-   in
-   GEN t1 (GEN t2 (DISCH t1 (DISCH t2 (EQ_MP (SYM th2) th1))))
-   end;
-
-val _ = save_thm("AND_INTRO_THM", AND_INTRO_THM);
-
-(*---------------------------------------------------------------------------
- * |- !t1 t2. t1 /\ t2 ==> t1
- *---------------------------------------------------------------------------*)
-
-val AND1_THM =
-  let val t1 = --`t1:bool`--
-      and t2 = --`t2:bool`--
-      val th1 = ASSUME (--`^t1 /\ ^t2`--)
-      val th2 = RIGHT_BETA(AP_THM (RIGHT_BETA(AP_THM AND_DEF t1)) t2)
-      val th3 = SPEC t1 (EQ_MP th2 th1)
-      val th4 = DISCH t1 (DISCH t2 (ADD_ASSUM t2 (ASSUME t1)))
-  in
-  GEN t1 (GEN t2 (DISCH (--`^t1 /\ ^t2`--) (MP th3 th4)))
-  end;
-
-val _ = save_thm("AND1_THM", AND1_THM);
-
-
-(*---------------------------------------------------------------------------
- *    |- !t1 t2. t1 /\ t2 ==> t2
- *---------------------------------------------------------------------------*)
-
-val AND2_THM =
-  let val t1 = --`t1:bool`--
-      and t2 = --`t2:bool`--
-      val th1 = ASSUME (--`^t1 /\ ^t2`--)
-      val th2 = RIGHT_BETA(AP_THM (RIGHT_BETA(AP_THM AND_DEF t1)) t2)
-      val th3 = SPEC t2 (EQ_MP th2 th1)
-      val th4 = DISCH t1 (DISCH t2 (ADD_ASSUM t1 (ASSUME t2)))
-  in
-  GEN t1 (GEN t2 (DISCH (--`^t1 /\ ^t2`--) (MP th3 th4)))
-  end;
-
-val _ = save_thm("AND2_THM", AND2_THM);
-
-(* CONJ, CONJUNCT1 and CONJUNCT2 should be built here.*)
-
-fun CONJ_PAIR thm = (CONJUNCT1 thm, CONJUNCT2 thm);
-
-fun CONJUNCTS th =
-  (CONJUNCTS (CONJUNCT1 th) @ CONJUNCTS (CONJUNCT2 th)) handle _ => [th];
-
-(*---------------------------------------------------------------------------
- *   |- !t1 t2. (t1 /\ t2) = (t2 /\ t1)
- *---------------------------------------------------------------------------*)
-
-val CONJ_SYM =
-  let val t1 = --`t1:bool`--
-      and t2 = --`t2:bool`--
-      val th1 = ASSUME (--`^t1 /\ ^t2`--)
-      and th2 = ASSUME (--`^t2 /\ ^t1`--)
-  in
-  GEN t1 (GEN t2 (IMP_ANTISYM_RULE
-                 (DISCH (--`^t1 /\ ^t2`--)
-                        (CONJ(CONJUNCT2 th1)(CONJUNCT1 th1)))
-                 (DISCH (--`^t2 /\ ^t1`--)
-                        (CONJ(CONJUNCT2 th2)(CONJUNCT1 th2)))))
-  end;
-
-val _ = save_thm("CONJ_SYM", CONJ_SYM);
-val _ = save_thm("CONJ_COMM", CONJ_SYM);
-
-(*---------------------------------------------------------------------------
- * |- !t1 t2 t3. t1 /\ (t2 /\ t3) = (t1 /\ t2) /\ t3
- *---------------------------------------------------------------------------*)
-
-val CONJ_ASSOC =
-  let val t1 = --`t1:bool`--
-      and t2 = --`t2:bool`--
-      and t3 = --`t3:bool`--
-      val th1 = ASSUME (--`^t1 /\ (^t2 /\ ^t3)`--)
-      val th2 = ASSUME (--`(^t1 /\ ^t2) /\ ^t3`--)
-      val th3 = DISCH (--`^t1 /\ (^t2 /\ ^t3)`--)
-                   (CONJ (CONJ(CONJUNCT1 th1)
-                              (CONJUNCT1(CONJUNCT2 th1)))
-                         (CONJUNCT2(CONJUNCT2 th1)))
-      and th4 = DISCH (--`(^t1 /\ ^t2) /\ ^t3`--)
-                   (CONJ (CONJUNCT1(CONJUNCT1 th2))
-                         (CONJ(CONJUNCT2(CONJUNCT1 th2))
-                              (CONJUNCT2 th2)))
-  in
-  GEN t1 (GEN t2 (GEN t3 (IMP_ANTISYM_RULE th3 th4)))
-  end;
-
-val _ = save_thm("CONJ_ASSOC", CONJ_ASSOC);
-
-
-(*---------------------------------------------------------------------------
- *  |- !t1 t2. t1 ==> t1 \/ t2
- *---------------------------------------------------------------------------*)
-
-val OR_INTRO_THM1 =
-  let val t = --`t:bool`--
-      and t1 = --`t1:bool`--
-      and t2 = --`t2:bool`--
-      val th1 = ADD_ASSUM (--`^t2 ==> ^t`--) (MP (ASSUME (--`^t1 ==> ^t`--))
-                                              (ASSUME t1))
-      val th2 = GEN t (DISCH (--`^t1 ==> ^t`--) (DISCH (--`^t2 ==> ^t`--) th1))
-      val th3 = RIGHT_BETA(AP_THM (RIGHT_BETA(AP_THM OR_DEF t1)) t2)
-  in
-    GEN t1 (GEN t2 (DISCH t1 (EQ_MP (SYM th3) th2)))
-  end;
-
-val _ = save_thm("OR_INTRO_THM1", OR_INTRO_THM1);
-
-(*---------------------------------------------------------------------------
- * |- !t1 t2. t2 ==> t1 \/ t2
- *---------------------------------------------------------------------------*)
-
-val OR_INTRO_THM2 =
-  let val t  = --`t:bool`--
-      and t1 = --`t1:bool`--
-      and t2 = --`t2:bool`--
-      val th1 = ADD_ASSUM (--`^t1 ==> ^t`--)
-                     (MP (ASSUME (--`^t2 ==> ^t`--)) (ASSUME t2))
-      val th2 = GEN t (DISCH (--`^t1 ==> ^t`--) (DISCH (--`^t2 ==> ^t`--) th1))
-      val th3 = RIGHT_BETA(AP_THM (RIGHT_BETA(AP_THM OR_DEF t1)) t2)
-  in
-    GEN t1 (GEN t2 (DISCH t2 (EQ_MP (SYM th3) th2)))
-  end;
-
-val _ = save_thm("OR_INTRO_THM2", OR_INTRO_THM2);
-
-(*---------------------------------------------------------------------------
- * |- !t t1 t2. (t1 \/ t2) ==> (t1 ==> t) ==> (t2 ==> t) ==> t
- *---------------------------------------------------------------------------*)
-
-val OR_ELIM_THM =
-   let val t =  --`t:bool`--
-       and t1 = --`t1:bool`--
-       and t2 = --`t2:bool`--
-       val th1 = ASSUME (--`^t1 \/ ^t2`--)
-       val th2 = UNFOLD_OR_CONV (concl th1)
-       val th3 = SPEC t (EQ_MP th2 th1)
-       val th4 = MP (MP th3 (ASSUME (--`^t1 ==> ^t`--)))
-                    (ASSUME (--`^t2 ==> ^t`--))
-       val th4 = DISCH (--`^t1 ==> ^t`--) (DISCH (--`^t2 ==> ^t`--) th4)
-   in
-   GEN t (GEN t1 (GEN t2 (DISCH (--`^t1 \/ ^t2`--) th4)))
-   end;
-
-val _ = save_thm("OR_ELIM_THM", OR_ELIM_THM);
-
-(* DISJ1, DISJ2, DISJ_CASES should be built here. *)
-
-fun DISJ_CASES_UNION dth ath bth =
-    DISJ_CASES dth (DISJ1 ath (concl bth)) (DISJ2 (concl ath) bth);
-
-
-(*---------------------------------------------------------------------------
- * |- !t. (t ==> F) ==> ~t
- *---------------------------------------------------------------------------*)
-
-val IMP_F =
-   let val t = --`t:bool`--
-       val th1 = RIGHT_BETA (AP_THM NOT_DEF t)
-   in
-     GEN t (DISCH (--`^t ==> F`--)
-                 (EQ_MP (SYM th1) (ASSUME (--`^t ==> F`--))))
-   end;
-
-val _ = save_thm("IMP_F", IMP_F);
-
-
-(*---------------------------------------------------------------------------
- * |- !t. ~t ==> (t ==> F)
- *---------------------------------------------------------------------------*)
-
-val F_IMP =
-   let val t = --`t:bool`--
-       val th1 = RIGHT_BETA(AP_THM NOT_DEF t)
-   in
-   GEN t (DISCH (--`~^t`--)
-                (EQ_MP th1 (ASSUME (--`~^t`--))))
-   end;
-
-val _ = save_thm("F_IMP", F_IMP);
-
-
-(*---------------------------------------------------------------------------
- * |- !t. ~t ==> (t=F)
- *---------------------------------------------------------------------------*)
-
-val NOT_F =
-   let val t = --`t:bool`--
-       val th1 = MP (SPEC t F_IMP) (ASSUME (--`~ ^t`--))
-       and th2 = SPEC t FALSITY
-       val th3 = IMP_ANTISYM_RULE th1 th2
-   in
-   GEN t (DISCH (--`~^t`--) th3)
-   end;
-
-val _ = save_thm("NOT_F", NOT_F);
-
-(*---------------------------------------------------------------------------
- *  |- !t. ~(t /\ ~t)
- *---------------------------------------------------------------------------*)
-
-val NOT_AND =
-   let val th = ASSUME (--`t /\ ~t`--)
-   in NOT_INTRO(DISCH (--`t /\ ~t`--) (MP (CONJUNCT2 th) (CONJUNCT1 th)))
-   end;
-
-val _ = save_thm("NOT_AND", NOT_AND);
-
-
-(*---------------------------------------------------------------------------
- * |- !t. (T /\ t) = t
- *---------------------------------------------------------------------------*)
-
-val AND_CLAUSE1 =
-   let val t = --`t:bool`--
-       val th1 = DISCH (--`T /\ ^t`--) (CONJUNCT2(ASSUME (--`T /\ ^t`--)))
-       and th2 = DISCH t (CONJ TRUTH (ASSUME t))
-   in
-   GEN t (IMP_ANTISYM_RULE th1 th2)
-   end;
-
-
-(*---------------------------------------------------------------------------
- *  |- !t. (t /\ T) = t
- *---------------------------------------------------------------------------*)
-
-val AND_CLAUSE2 =
-   let val t = --`t:bool`--
-       val th1 = DISCH (--`^t /\ T`--) (CONJUNCT1(ASSUME (--`^t /\ T`--)))
-       and th2 = DISCH t (CONJ (ASSUME t) TRUTH)
-   in
-     GEN t (IMP_ANTISYM_RULE th1 th2)
-   end;
-
-
-(*---------------------------------------------------------------------------
- *   |- !t. (F /\ t) = F
- *---------------------------------------------------------------------------*)
-
-val AND_CLAUSE3 =
-   let val t = --`t:bool`--
-       val th1 = IMP_TRANS (SPEC t (SPEC (--`F`--) AND1_THM))
-                           (SPEC (--`F`--) FALSITY)
-       and th2 = SPEC (--`F /\ ^t`--) FALSITY
-   in
-     GEN t (IMP_ANTISYM_RULE th1 th2)
-   end;
-
-(*---------------------------------------------------------------------------
- *   |- !t. (t /\ F) = F
- *---------------------------------------------------------------------------*)
-
-val AND_CLAUSE4 =
-   let val t = --`t:bool`--
-       val th1 = IMP_TRANS (SPEC (--`F`--) (SPEC t AND2_THM))
-                           (SPEC (--`F`--) FALSITY)
-       and th2 = SPEC (--`^t /\ F`--) FALSITY
-   in
-     GEN t (IMP_ANTISYM_RULE th1 th2)
-   end;
-
-
-(*---------------------------------------------------------------------------
- *    |- !t. (t /\ t) = t
- *---------------------------------------------------------------------------*)
-
-val AND_CLAUSE5 =
-   let val t = --`t:bool`--
-       val th1 = DISCH (--`^t /\ ^t`--) (CONJUNCT1(ASSUME (--`^t /\ ^t`--)))
-       and th2 = DISCH t (CONJ(ASSUME t)(ASSUME t))
-   in
-     GEN t (IMP_ANTISYM_RULE th1 th2)
-   end;
-
-(*---------------------------------------------------------------------------
- *  |- !t. (T /\ t) = t /\
- *         (t /\ T) = t /\
- *         (F /\ t) = F /\
- *         (t /\ F) = F /\
- *         (t /\ t) = t
- *---------------------------------------------------------------------------*)
-
-val AND_CLAUSES =
-   let val t = --`t:bool`--
-   in
-   GEN t (CONJ
-           (SPEC t AND_CLAUSE1)
-            (CONJ
-             (SPEC t AND_CLAUSE2)
-              (CONJ
-               (SPEC t AND_CLAUSE3)
-                 (CONJ (SPEC t AND_CLAUSE4)
-                       (SPEC t AND_CLAUSE5)))))
-   end;
-
-val _ = save_thm("AND_CLAUSES", AND_CLAUSES);
-
-(*---------------------------------------------------------------------------
- *   |- !t. (T \/ t) = T
- *---------------------------------------------------------------------------*)
-
-val OR_CLAUSE1 =
-   let val t = --`t:bool`--
-       val th1 = DISCH (--`T \/ ^t`--) TRUTH
-       and th2 = DISCH (--`T`--) (DISJ1 TRUTH t)
-   in
-   GEN t (IMP_ANTISYM_RULE th1 th2)
-   end;
-
-(*---------------------------------------------------------------------------
- *  |- !t. (t \/ T) = T
- *---------------------------------------------------------------------------*)
-
-val OR_CLAUSE2 =
-   let val t = --`t:bool`--
-       val th1 = DISCH (--`^t \/ T`--) TRUTH
-       and th2 = DISCH (--`T`--) (DISJ2 t TRUTH)
-   in
-   GEN t (IMP_ANTISYM_RULE th1 th2)
-   end;
-
-(*---------------------------------------------------------------------------
- *    |- (F \/ t) = t
- *---------------------------------------------------------------------------*)
-
-val OR_CLAUSE3 =
-   let val t = --`t:bool`--
-       val th1 = DISCH (--`F \/ ^t`--) (DISJ_CASES (ASSUME (--`F \/ ^t`--))
-                                        (UNDISCH (SPEC t FALSITY))
-                                        (ASSUME t))
-       and th2 = SPEC t (SPEC (--`F`--) OR_INTRO_THM2)
-   in
-   GEN t (IMP_ANTISYM_RULE th1 th2)
-   end;
-
-(*---------------------------------------------------------------------------
- *    |- !t. (t \/ F) = t
- *---------------------------------------------------------------------------*)
-
-val OR_CLAUSE4 =
-   let val t = --`t:bool`--
-       val th1 = DISCH (--`^t \/ F`--) (DISJ_CASES (ASSUME (--`^t \/ F`--))
-                                             (ASSUME t)
-                                             (UNDISCH (SPEC t FALSITY)))
-       and th2 = SPEC (--`F`--) (SPEC t OR_INTRO_THM1)
-   in
-   GEN t (IMP_ANTISYM_RULE th1 th2)
-   end;
-
-(*---------------------------------------------------------------------------
- *   |- !t. (t \/ t) = t
- *---------------------------------------------------------------------------*)
-
-val OR_CLAUSE5 =
-   let val t = --`t:bool`--
-       val th1 = DISCH (--`^t \/ ^t`--)
-                  (DISJ_CASES(ASSUME (--`^t \/ ^t`--)) (ASSUME t) (ASSUME t))
-       and th2 = DISCH t (DISJ1(ASSUME t)t)
-   in
-   GEN t (IMP_ANTISYM_RULE th1 th2)
-   end;
-
-(*---------------------------------------------------------------------------
- * |- !t. (T \/ t) = T /\
- *        (t \/ T) = T /\
- *        (F \/ t) = t /\
- *        (t \/ F) = t /\
- *        (t \/ t) = t
- *---------------------------------------------------------------------------*)
-
-val OR_CLAUSES =
-   let val t = --`t:bool`--
-   in
-   GEN t (CONJ
-          (SPEC t OR_CLAUSE1)
-          (CONJ
-           (SPEC t OR_CLAUSE2)
-           (CONJ
-            (SPEC t OR_CLAUSE3)
-            (CONJ (SPEC t OR_CLAUSE4)
-                  (SPEC t OR_CLAUSE5)))))
-   end;
-
-val _ = save_thm("OR_CLAUSES", OR_CLAUSES);
-
-
-(*---------------------------------------------------------------------------
- *  |- !t. (T ==> t) = t
- *---------------------------------------------------------------------------*)
-
-val IMP_CLAUSE1 =
-   let val t = --`t:bool`--
-       val th1 = DISCH (--`T ==> ^t`--) (MP (ASSUME (--`T ==> ^t`--)) TRUTH)
-       and th2 = DISCH t (DISCH (--`T`--) (ADD_ASSUM (--`T`--) (ASSUME t)))
-   in
-   GEN t (IMP_ANTISYM_RULE th1 th2)
-   end;
-
-(*---------------------------------------------------------------------------
- *  |- !t. (F ==> t) = T
- *---------------------------------------------------------------------------*)
-
-val IMP_CLAUSE2 =
-   let val t = --`t:bool`--
-   in GEN t (EQT_INTRO(SPEC t FALSITY))
-   end;
-
-(*---------------------------------------------------------------------------
- *  |- !t. (t ==> T) = T
- *---------------------------------------------------------------------------*)
-
-val IMP_CLAUSE3 =
-   let val t = --`t:bool`--
-   in GEN t (EQT_INTRO(DISCH t (ADD_ASSUM t TRUTH)))
-   end;
-
-(*---------------------------------------------------------------------------
- *  |- ((T ==> F) = F) /\ ((F ==> F) = T)
- *---------------------------------------------------------------------------*)
-val IMP_CLAUSE4 =
-   let val th1 = DISCH (--`T ==> F`--) (MP (ASSUME (--`T ==> F`--)) TRUTH)
-       and th2 = SPEC (--`T ==> F`--) FALSITY
-       and th3 = EQT_INTRO(DISCH (--`F`--) (ASSUME (--`F`--)))
-   in
-   CONJ(IMP_ANTISYM_RULE th1 th2) th3
-   end;
-
-(*---------------------------------------------------------------------------
- *  |- !t. (t ==> F) = ~t
- *---------------------------------------------------------------------------*)
-
-val IMP_CLAUSE5 =
-    let val t = --`t:bool`--
-        val th1 = SPEC t IMP_F
-        and th2 = SPEC t F_IMP
-    in
-    GEN t (IMP_ANTISYM_RULE th1 th2)
-    end;
-
-(*---------------------------------------------------------------------------
- *  |- !t. (T ==> t) = t /\
- *         (t ==> T) = T /\
- *         (F ==> t) = T /\
- *         (t ==> t) = t /\
- *         (t ==> F) = ~t
- *---------------------------------------------------------------------------*)
-
-val IMP_CLAUSES =
-   let val t = --`t:bool`--
-   in GEN t
-      (CONJ (SPEC t IMP_CLAUSE1)
-            (CONJ (SPEC t IMP_CLAUSE3)
-                  (CONJ (SPEC t IMP_CLAUSE2)
-                        (CONJ (EQT_INTRO(DISCH t (ASSUME t)))
-                              (SPEC t IMP_CLAUSE5)))))
-   end;
-
-val _ = save_thm("IMP_CLAUSES", IMP_CLAUSES);
-
-
-(*----------------------------------------------------------------------------
- *    |- (~~t = t) /\ (~T = F) /\ (~F = T)
- *---------------------------------------------------------------------------*)
-
-val NOT_CLAUSES =
- CONJ
-  (GEN (--`t:bool`--)
-    (IMP_ANTISYM_RULE
-      (DISJ_IMP(IMP_ELIM(DISCH (--`t:bool`--) (ASSUME (--`t:bool`--)))))
-      (DISCH (--`t:bool`--)
-       (NOT_INTRO(DISCH (--`~t`--) (UNDISCH (NOT_ELIM(ASSUME (--`~t`--)))))))))
-  (CONJ (IMP_ANTISYM_RULE
-          (DISCH (--`~T`--)
-                 (MP (MP (SPEC (--`T`--) F_IMP) (ASSUME (--`~T`--))) TRUTH))
-          (SPEC (--`~T`--) FALSITY))
-        (IMP_ANTISYM_RULE (DISCH (--`~F`--) TRUTH)
-                          (DISCH (--`T`--) (MP (SPEC (--`F`--) IMP_F)
-                                               (SPEC (--`F`--) FALSITY)))));
-
-val _ = save_thm("NOT_CLAUSES", NOT_CLAUSES);
-
-(*---------------------------------------------------------------------------
- *   |- !x. x=x
- *---------------------------------------------------------------------------*)
-
-val EQ_REFL = GEN (--`x : 'a`--) (REFL (--`x : 'a`--));
-
-val _ = save_thm("EQ_REFL", EQ_REFL);
-
-(*---------------------------------------------------------------------------
- *   |- !x. (x=x) = T
- *---------------------------------------------------------------------------*)
-
-val REFL_CLAUSE = GEN (--`x: 'a`--) (EQT_INTRO(SPEC (--`x:'a`--) EQ_REFL));
-
-val _ = save_thm("REFL_CLAUSE", REFL_CLAUSE );
-
-(*---------------------------------------------------------------------------
- *   |- !x y. x=y  ==>  y=x
- *---------------------------------------------------------------------------*)
-
-val EQ_SYM =
- let val x = --`x:'a`--
-     and y = --`y:'a`--
- in
-   GEN x (GEN y (DISCH (--`^x = ^y`--) (SYM(ASSUME (--`^x = ^y`--)))))
- end;
-
-val _ = save_thm("EQ_SYM",EQ_SYM);
-
-(*---------------------------------------------------------------------------
- *    |- !x y. (x = y) = (y = x)
- *---------------------------------------------------------------------------*)
-
-val EQ_SYM_EQ =
-   GEN (--`x:'a`--)
-    (GEN (--`y:'a`--)
-      (IMP_ANTISYM_RULE (SPEC (--`y:'a`--) (SPEC (--`x:'a`--) EQ_SYM))
-                        (SPEC (--`x:'a`--) (SPEC (--`y:'a`--) EQ_SYM))));
-
-val _ = save_thm("EQ_SYM_EQ",EQ_SYM_EQ);
-
-(*---------------------------------------------------------------------------
- *    |- !f g. (!x. f x = g x)  ==>  f=g
- *---------------------------------------------------------------------------*)
-
-val EQ_EXT =
-   let val f = (--`f:'a->'b`--)
-       and g = (--`g: 'a -> 'b`--)
-   in
-   GEN f (GEN g (DISCH (--`!x:'a. ^f (x:'a) = ^g (x:'a)`--)
-                       (EXT(ASSUME (--`!x:'a. ^f (x:'a) = ^g (x:'a)`--)))))
-   end;
-
-val _ = save_thm("EQ_EXT",EQ_EXT);
-
-(*---------------------------------------------------------------------------
-      FUN_EQ_THM  |- !f g. (f = g) = !x. f x = g x
- ---------------------------------------------------------------------------*)
-
-val FUN_EQ_THM =
-  let val f = mk_var("f", Type.alpha --> Type.beta)
-      val g = mk_var("g", Type.alpha --> Type.beta)
-      val x = mk_var("x", Type.alpha)
-      val f_eq_g = mk_eq(f,g)
-      val fx_eq_gx = mk_eq(mk_comb(f,x),mk_comb(g,x))
-      val uq_f_eq_g = mk_forall(x,fx_eq_gx)
-      val th1 = GEN x (AP_THM (ASSUME f_eq_g) x);
-      val th2 = MP (SPEC_ALL EQ_EXT) (ASSUME uq_f_eq_g);
-  in
-    GEN f (GEN g
-        (IMP_ANTISYM_RULE (DISCH_ALL th1) (DISCH_ALL th2)))
-  end;
-
-val _ = save_thm("FUN_EQ_THM",FUN_EQ_THM);
-
-(*---------------------------------------------------------------------------
- *    |- !x y z. x=y  /\  y=z  ==>  x=z
- *---------------------------------------------------------------------------*)
-
-val EQ_TRANS =
-   let val x = --`x:'a`--
-       and y = --`y:'a`--
-       and z = --`z:'a`--
-       val xyyz  = (--`(^x = ^y) /\ (^y = ^z)`--)
-   in
-   GEN x
-    (GEN y
-     (GEN z
-      (DISCH xyyz
-       (TRANS (CONJUNCT1(ASSUME xyyz))
-              (CONJUNCT2(ASSUME xyyz))))))
-   end;
-
-val _ = save_thm("EQ_TRANS",EQ_TRANS);
-
-(*---------------------------------------------------------------------------
- *     |- ~(T=F) /\ ~(F=T)
- *---------------------------------------------------------------------------*)
-
-val BOOL_EQ_DISTINCT =
-   let val TF = --`T = F`--
-       and FT = --`F = T`--
-   in
-   CONJ
-    (NOT_INTRO(DISCH TF (EQ_MP (ASSUME TF) TRUTH)))
-    (NOT_INTRO(DISCH FT (EQ_MP (SYM(ASSUME FT)) TRUTH)))
-   end;
-
-val _ = save_thm("BOOL_EQ_DISTINCT", BOOL_EQ_DISTINCT);
-
-
-(*---------------------------------------------------------------------------
- *     |- !t. (T = t) = t
- *---------------------------------------------------------------------------*)
-
-val EQ_CLAUSE1 =
-   let val t = --`t:bool`--
-       val Tt = --`T = ^t`--
-       val th1 = DISCH Tt (EQ_MP (ASSUME Tt) TRUTH)
-       and th2 = DISCH t (SYM(EQT_INTRO(ASSUME t)))
-   in
-   GEN t (IMP_ANTISYM_RULE th1 th2)
-   end;
-
-
-(*---------------------------------------------------------------------------
- *  |- !t. (t = T) = t
- *---------------------------------------------------------------------------*)
-
-val EQ_CLAUSE2 =
-   let val t = --`t:bool`--
-       val tT = --`^t = T`--
-       val th1 = DISCH tT (EQ_MP (SYM (ASSUME tT)) TRUTH)
-       and th2 = DISCH t (EQT_INTRO(ASSUME t))
-   in
-   GEN t (IMP_ANTISYM_RULE th1 th2)
-   end;
-
-
-(*---------------------------------------------------------------------------
- *    |- !t. (F = t) = ~t
- *---------------------------------------------------------------------------*)
-
-val EQ_CLAUSE3 =
-   let val t = --`t:bool`--
-       val Ft = --`F = ^t`--
-       val tF = --`^t = F`--
-       val th1 = DISCH Ft (MP (SPEC t IMP_F)
-                              (DISCH t (EQ_MP(SYM(ASSUME Ft))
-                                             (ASSUME t))))
-       and th2 = IMP_TRANS (SPEC t NOT_F)
-                           (DISCH tF (SYM(ASSUME tF)))
-   in
-   GEN t (IMP_ANTISYM_RULE th1 th2)
-   end;
-
-
-(*---------------------------------------------------------------------------
- *  |- !t. (t = F) = ~t
- *---------------------------------------------------------------------------*)
-
-val EQ_CLAUSE4 =
-   let val t = --`t:bool`--
-       val tF = --`^t = F`--
-       val th1 = DISCH tF (MP (SPEC t IMP_F)
-                              (DISCH t (EQ_MP(ASSUME tF)
-                                             (ASSUME t))))
-       and th2 = SPEC t NOT_F
-   in
-   GEN t (IMP_ANTISYM_RULE th1 th2)
-   end;
-
-
-(*---------------------------------------------------------------------------
- *  |- !t.  (T = t)  =  t  /\
- *          (t = T)  =  t  /\
- *          (F = t)  =  ~t /\
- *          (t = F)  =  ~t
- *---------------------------------------------------------------------------*)
-
-val EQ_CLAUSES =
-   let val t = --`t:bool`--
-   in
-   GEN t (CONJ
-           (SPEC t EQ_CLAUSE1)
-            (CONJ
-              (SPEC t EQ_CLAUSE2)
-                (CONJ (SPEC t EQ_CLAUSE3)
-                      (SPEC t EQ_CLAUSE4))))
-   end;
-
-val _ = save_thm("EQ_CLAUSES", EQ_CLAUSES);
-
-
-(*---------------------------------------------------------------------------
- *    |- !t1 t2 :'a. COND T t1 t2 = t1
- *---------------------------------------------------------------------------*)
-
-val COND_CLAUSE1 =
- let val (x,t1,t2,v) = (Term`x:'a`, Term`t1:'a`,
-                        Term`t2:'a`, genvar Type.bool)
-     val th1 = RIGHT_BETA(AP_THM
-                 (RIGHT_BETA(AP_THM
-                    (RIGHT_BETA(AP_THM COND_DEF (--`T`--))) t1))t2)
-     val TT = EQT_INTRO(REFL (--`T`--))
-     val th2 = SUBST [v |-> SYM TT]
-                     (--`(^v ==> (^x=^t1)) = (^x=^t1)`--)
-                     (CONJUNCT1 (SPEC (--`^x=^t1`--) IMP_CLAUSES))
-     and th3 = DISCH (--`T=F`--)
-                     (MP (SPEC (--`^x=^t2`--) FALSITY)
-                         (UNDISCH(MP (SPEC (--`T=F`--) F_IMP)
-                                     (CONJUNCT1 BOOL_EQ_DISTINCT))))
-     val th4 = DISCH (--`^x=^t1`--)
-                     (CONJ(EQ_MP(SYM th2)(ASSUME (--`^x=^t1`--)))th3)
-     and th5 = DISCH (--`((T=T) ==> (^x=^t1))/\((T=F) ==> (^x=^t2))`--)
-                     (MP (CONJUNCT1(ASSUME (--`((T=T) ==> (^x=^t1))/\
-                                               ((T=F) ==> (^x=^t2))`--)))
-                         (REFL (--`T`--)))
-     val th6 = IMP_ANTISYM_RULE th4 th5
-     val th7 = TRANS th1 (SYM(SELECT_EQ x th6))
-     val th8 = EQ_MP (SYM(BETA_CONV (--`(\ ^x.^x = ^t1) ^t1`--))) (REFL t1)
-     val th9 = MP (SPEC t1 (SPEC (--`\ ^x.^x = ^t1`--) SELECT_AX)) th8
- in
-   GEN t1 (GEN t2 (TRANS th7 (EQ_MP (BETA_CONV(concl th9)) th9)))
- end;
-
-
-(*---------------------------------------------------------------------------
- *    |- !tm1 tm2:'a. COND F tm1 tm2 = tm2
- *
- *   Note that there is a bound variable conflict if we use use t1
- *   and t2 as the variable names. That would be a good test of the
- *   substitution algorithm.
- *---------------------------------------------------------------------------*)
-
-val COND_CLAUSE2 =
-   let val (x,t1,t2,v) = (--`x:'a`--,  --`tm1:'a`--, --`tm2:'a`--,
-                          genvar Type.bool)
-       val th1 = RIGHT_BETA(AP_THM
-                   (RIGHT_BETA(AP_THM
-                     (RIGHT_BETA(AP_THM COND_DEF (--`F`--))) t1))t2)
-       val FF = EQT_INTRO(REFL (--`F`--))
-       val th2 = SUBST [v |-> SYM FF]
-                       (--`(^v ==> (^x=^t2))=(^x=^t2)`--)
-                       (CONJUNCT1(SPEC (--`^x=^t2`--) IMP_CLAUSES))
-       and th3 = DISCH (--`F=T`--) (MP (SPEC (--`^x=^t1`--) FALSITY)
-                                 (UNDISCH (MP (SPEC (--`F=T`--) F_IMP)
-                                              (CONJUNCT2 BOOL_EQ_DISTINCT))))
-       val th4 = DISCH (--`^x=^t2`--)
-                       (CONJ th3 (EQ_MP(SYM th2)(ASSUME (--`^x=^t2`--))))
-       and th5 = DISCH (--`((F=T) ==> (^x=^t1)) /\ ((F=F) ==> (^x=^t2))`--)
-                       (MP (CONJUNCT2(ASSUME (--`((F=T) ==> (^x=^t1)) /\
-                                                 ((F=F) ==> (^x=^t2))`--)))
-                           (REFL (--`F`--)))
-       val th6 = IMP_ANTISYM_RULE th4 th5
-       val th7 = TRANS th1 (SYM(SELECT_EQ x th6))
-       val th8 = EQ_MP (SYM(BETA_CONV (--`(\ ^x.^x = ^t2) ^t2`--)))
-                       (REFL t2)
-       val th9 = MP (SPEC t2 (SPEC (--`\ ^x.^x = ^t2`--) SELECT_AX)) th8
-   in
-     GEN t1 (GEN t2 (TRANS th7 (EQ_MP (BETA_CONV(concl th9)) th9)))
-   end;
-
-
-(*---------------------------------------------------------------------------
- *    |- !t1:'a.!t2:'a. ((T => t1 | t2) = t1) /\ ((F => t1 | t2) = t2)
- *---------------------------------------------------------------------------*)
-
-val COND_CLAUSES =
-   let val (t1,t2) = (--`t1:'a`--, --`t2:'a`--)
-   in
-   GEN t1 (GEN t2 (CONJ(SPEC t2(SPEC t1 COND_CLAUSE1))
-                       (SPEC t2(SPEC t1 COND_CLAUSE2))))
-   end;
-
-val _ = save_thm("COND_CLAUSES", COND_CLAUSES);
-
-
-(*--------------------------------------------------------------------- *)
-(* |- b. !t. (b => t | t) = t						*)
-(*					                   TFM 90.07.23 *)
-(*--------------------------------------------------------------------- *)
-
-val COND_ID =
-   let val b = --`b:bool`--
-       and t = --`t:'a`--
-       val def = INST_TYPE [==`:'b`==  |->  ==`:'a`==] COND_DEF
-       val th1 = itlist (fn x => RIGHT_BETA o (C AP_THM x))
-                        [t,t,b] def
-       val p = genvar (==`:bool`==)
-       val asm1 = ASSUME (--`((^b=T)==>^p) /\ ((^b=F)==>^p)`--)
-       val th2 = DISJ_CASES (SPEC b BOOL_CASES_AX)
-                            (UNDISCH (CONJUNCT1 asm1))
-                            (UNDISCH (CONJUNCT2 asm1))
-       val imp1 = DISCH (concl asm1) th2
-       val asm2 = ASSUME p
-       val imp2 = DISCH p (CONJ (DISCH (--`^b=T`--)
-                                       (ADD_ASSUM (--`^b=T`--) asm2))
-	                        (DISCH (--`^b=F`--)
-                                       (ADD_ASSUM (--`^b=F`--) asm2)))
-       val lemma = SPEC (--`x:'a = ^t`--)
-                        (GEN p (IMP_ANTISYM_RULE imp1 imp2))
-       val th3 = TRANS th1 (SELECT_EQ (--`x:'a`--) lemma)
-       val th4 = EQ_MP (SYM(BETA_CONV (--`(\x.x = ^t) ^t`--)))
-                       (REFL t)
-       val th5 = MP (SPEC t (SPEC (--`\x.x = ^t` --) SELECT_AX)) th4
-       val lemma2 = EQ_MP (BETA_CONV(concl th5)) th5
-   in
-     GEN b (GEN t (TRANS th3 lemma2))
-   end;
-
-val _ = save_thm("COND_ID", COND_ID);
-
-(*---------------------------------------------------------------------------
-      SELECT_THM = |- !P. P (@x. P x) = ?x. P x
- ---------------------------------------------------------------------------*)
-
-val SELECT_THM =
-  GEN (Term`P:'a->bool`)
-   (SYM (RIGHT_BETA(RIGHT_BETA
-          (AP_THM EXISTS_DEF (Term`\x:'a. P x:bool`)))));
-
-val _ = save_thm("SELECT_THM", SELECT_THM);
-
-(* ---------------------------------------------------------------------*)
-(* SELECT_REFL = |- !x. (@y. y = x) = x                                 *)
-(* ---------------------------------------------------------------------*)
-
-val SELECT_REFL =
-  let val th1 = SPEC (--`x:'a`--)
-                      (SPEC (--`\y:'a. y = x`--) SELECT_AX)
-      val ths = map BETA_CONV [--`(\y:'a. y = x) x`--,
-                               --`(\y:'a. y = x)(@y. y = x)`--]
-      val th2 = SUBST[Term`u:bool` |-> el 1 ths, Term`v:bool` |-> el 2 ths]
-                     (Term`u ==> v`) th1
-  in
-  GEN (--`x:'a`--) (MP th2 (REFL (--`x:'a`--)))
-  end;
-
-val _ = save_thm("SELECT_REFL", SELECT_REFL);
-
-val SELECT_REFL_2 =
-  let val x = mk_var("x",   Type.alpha)
-      val y = mk_var("y",   Type.alpha)
-      val th1 = REFL x
-      val th2 = EXISTS (mk_exists(y,mk_eq(x,y)),x) th1
-      val th3 = SPEC y (SPEC (mk_abs(y,mk_eq(x,y))) SELECT_AX)
-     val th4 = UNDISCH th3
-     val th5 = DISCH_ALL(SYM (EQ_MP (BETA_CONV (concl th4)) th4))
-     val th6 = UNDISCH(CONV_RULE (RATOR_CONV (RAND_CONV BETA_CONV)) th5)
- in
-   GEN x (CHOOSE(y,th2) th6)
- end;
-
-val _ = save_thm("SELECT_REFL_2", SELECT_REFL_2);
-
-(*---------------------------------------------------------------------------*)
-(* SELECT_UNIQUE = |- !P x. (!y. P y = (y = x)) ==> ($@ P = x)               *)
-(*---------------------------------------------------------------------------*)
-
-val SELECT_UNIQUE =
-  let fun mksym tm = DISCH tm (SYM(ASSUME tm))
-      val th0 = IMP_ANTISYM_RULE (mksym (--`y:'a = x`--))
-                                 (mksym (--`x:'a = y`--))
-      val th1 = SPEC (--`y:'a`--) (ASSUME (--`!y:'a. P y = (y = x)`--))
-      val th2 = EXT(GEN (--`y:'a`--) (TRANS th1 th0))
-      val th3 = AP_TERM (--`$@ :('a->bool)->'a`--) th2
-      val th4 = TRANS (BETA_CONV (--`(\y:'a. y = x) y`--)) th0
-      val th5 = AP_TERM (--`$@ :('a->bool)->'a`--) (EXT(GEN (--`y:'a`--) th4))
-      val th6 = TRANS (TRANS th3 (SYM th5)) (SPEC (--`x:'a`--) SELECT_REFL)
-  in
-  GENL [(--`P:'a->bool`--), (--`x:'a`--)]
-       (DISCH (--`!y:'a. P y = (y = x)`--) th6)
-  end;
-
-val _ = save_thm("SELECT_UNIQUE", SELECT_UNIQUE);
-
-(* ----------------------------------------------------------------------
-    SELECT_ELIM_THM = |- !P Q. (?x. P x) /\ (!x. P x ==> Q x) ==> Q ($@ P)
-   ---------------------------------------------------------------------- *)
-
-val SELECT_ELIM_THM = let
-  val P = mk_var("P", alpha --> bool)
-  val Q = mk_var("Q", alpha --> bool)
-  val x = mk_var("x", alpha)
-  val Px = mk_comb(P, x)
-  val Qx = mk_comb(Q, x)
-  val PimpQ = mk_imp(Px, Qx)
-  val allPimpQ = mk_forall(x, PimpQ)
-  val exPx = mk_exists (x, Px)
-  val selP = mk_comb(prim_mk_const{Thy = "min", Name = "@"}, P)
-  val asm_t = mk_conj(exPx, allPimpQ)
-  val asm = ASSUME asm_t
-  val (ex_th, forall_th) = CONJ_PAIR asm
-  val imp_th = SPEC selP forall_th
-  val Px_th = ASSUME Px
-  val PselP_th0 = UNDISCH (SPEC_ALL SELECT_AX)
-  val PselP_th = CHOOSE(x, ex_th) PselP_th0
-in
-  save_thm("SELECT_ELIM_THM", GENL [P, Q] (DISCH_ALL (MP imp_th PselP_th)))
-end
-
-(* -------------------------------------------------------------------------*)
-(* NOT_FORALL_THM = |- !P. ~(!x. P x) = ?x. ~P x                   	    *)
-(* -------------------------------------------------------------------------*)
-
-val NOT_FORALL_THM =
-    let val f = ``P:'a->bool``
-	val x = ``x:'a``
-	val t = mk_comb(f,x)
-	val all = mk_forall(x,t)
-	and exists = mk_exists(x,mk_neg t)
-	val nott = ASSUME (mk_neg t)
-	val th1 = DISCH all (MP nott (SPEC x (ASSUME all)))
-	val imp1 = DISCH exists (CHOOSE (x, ASSUME exists) (NOT_INTRO th1))
-	val th2 =
-	    CCONTR t (MP (ASSUME(mk_neg exists)) (EXISTS(exists,x)nott))
-	val th3 = CCONTR exists (MP (ASSUME (mk_neg all)) (GEN x th2))
-	val imp2 = DISCH (mk_neg all) th3
-    in
-	GEN f (IMP_ANTISYM_RULE imp2 imp1)
-    end;
-
-val _ = save_thm("NOT_FORALL_THM",NOT_FORALL_THM);
-
-
-(* ------------------------------------------------------------------------- *)
-(* NOT_EXISTS_THM = |- !P. ~(?x. P x) = (!x. ~P x)                   	    *)
-(* ------------------------------------------------------------------------- *)
-
-val NOT_EXISTS_THM =
-    let val f = (--`P:'a->bool`--)
-	val x = (--`x:'a`--)
-	val t = mk_comb(f,x)
-	val tm = mk_neg(mk_exists(x,t))
-	val all = mk_forall(x,mk_neg t)
-	val asm1 = ASSUME t
-	val thm1 = MP (ASSUME tm) (EXISTS (rand tm, x) asm1)
-	val imp1 = DISCH tm (GEN x (NOT_INTRO (DISCH t thm1)))
-	val asm2 = ASSUME  all and asm3 = ASSUME (rand tm)
-	val thm2 = DISCH (rand tm) (CHOOSE (x,asm3) (MP (SPEC x asm2) asm1))
-	val imp2 = DISCH all (NOT_INTRO thm2)
-    in
-	GEN f (IMP_ANTISYM_RULE imp1 imp2)
-    end;
-
-val _ = save_thm("NOT_EXISTS_THM",NOT_EXISTS_THM);
-
-
-(* ------------------------------------------------------------------------- *)
-(* FORALL_AND_THM |- !P Q. (!x. P x /\ Q x) = ((!x. P x) /\ (!x. Q x))       *)
-(* ------------------------------------------------------------------------- *)
-
-val FORALL_AND_THM =
-    let val f = (--`P:'a->bool`--)
-	val g = (--`Q:'a->bool`--)
-	val x = (--`x:'a`--)
-	val th1 = ASSUME (--`!x:'a. (P x) /\ (Q x)`--)
-	val imp1 =
-	    (uncurry CONJ) ((GEN x ## GEN x) (CONJ_PAIR (SPEC x th1)))
-	val th2 = ASSUME (--`(!x:'a. P x) /\ (!x:'a. Q x)`--)
-	val imp2 =
-	    GEN x (uncurry CONJ ((SPEC x ## SPEC x) (CONJ_PAIR th2)))
-    in
-	    GENL [f,g] (IMP_ANTISYM_RULE (DISCH_ALL imp1) (DISCH_ALL imp2))
-    end;
-
-val _ = save_thm("FORALL_AND_THM",FORALL_AND_THM);
-
-
-
-(* ------------------------------------------------------------------------- *)
-(* LEFT_AND_FORALL_THM = |- !P Q. (!x. P x) /\ Q = (!x. P x /\ Q)            *)
-(* ------------------------------------------------------------------------- *)
-
-val LEFT_AND_FORALL_THM =
-    let val x = (--`x:'a`--)
-	val f = (--`P:'a->bool`--)
-	val Q = (--`Q:bool`--)
-	val th1 = ASSUME (--`(!x:'a. P x) /\ Q`--)
-	val imp1 = GEN x ((uncurry CONJ) ((SPEC x ## I) (CONJ_PAIR th1)))
-	val th2 = ASSUME (--`!x:'a. P x /\ Q`--)
-	val imp2 = (uncurry CONJ) ((GEN x ## I) (CONJ_PAIR (SPEC x th2)))
-    in
-	GENL [f,Q] (IMP_ANTISYM_RULE (DISCH_ALL imp1) (DISCH_ALL imp2))
-    end;
-
-val _ = save_thm("LEFT_AND_FORALL_THM",LEFT_AND_FORALL_THM);
-
-
-(* ------------------------------------------------------------------------- *)
-(* RIGHT_AND_FORALL_THM = |- !P Q. P /\ (!x. Q x) = (!x. P /\ Q x)           *)
-(* ------------------------------------------------------------------------- *)
-
-val RIGHT_AND_FORALL_THM =
-    let	val x = (--`x:'a`--)
-	val P = (--`P:bool`--)
-	val g = (--`Q:'a->bool`--)
-	val th1 = ASSUME (--`P /\ (!x:'a. Q x)`--)
-	val imp1 = GEN x ((uncurry CONJ) ((I ## SPEC x) (CONJ_PAIR th1)))
-	val th2 = ASSUME (--`!x:'a. P /\ Q x`--)
-	val imp2 = (uncurry CONJ) ((I ## GEN x) (CONJ_PAIR (SPEC x th2)))
-    in
-	GENL [P,g] (IMP_ANTISYM_RULE (DISCH_ALL imp1) (DISCH_ALL imp2))
-    end;
-
-val _ = save_thm("RIGHT_AND_FORALL_THM",RIGHT_AND_FORALL_THM);
-
-
-(* ------------------------------------------------------------------------- *)
-(* EXISTS_OR_THM |- !P Q. (?x. P x \/ Q x) = ((?x. P x) \/ (?x. Q x))        *)
-(* ------------------------------------------------------------------------- *)
-
-val EXISTS_OR_THM =
-    let val f = (--`P:'a->bool`--)
-	val g = (--`Q:'a->bool`--)
-	val x = (--`x:'a`--)
-	val P = mk_comb(f,x)
-	val Q = mk_comb(g,x)
-	val tm = mk_exists (x,mk_disj(P,Q))
-	val ep = mk_exists (x,P)
-	and eq = mk_exists(x,Q)
-	val Pth = EXISTS(ep,x)(ASSUME P)
-	and Qth = EXISTS(eq,x)(ASSUME Q)
-	val thm1 = DISJ_CASES_UNION (ASSUME(mk_disj(P,Q))) Pth Qth
-	val imp1 = DISCH tm (CHOOSE (x,ASSUME tm) thm1)
-	val t1 = DISJ1 (ASSUME P) Q and t2 = DISJ2 P (ASSUME Q)
-	val th1 = EXISTS(tm,x) t1 and th2 = EXISTS(tm,x) t2
-	val e1 = CHOOSE (x,ASSUME ep) th1 and e2 = CHOOSE (x,ASSUME eq) th2
-	val thm2 = DISJ_CASES (ASSUME(mk_disj(ep,eq))) e1 e2
-	val imp2 = DISCH (mk_disj(ep,eq)) thm2
-    in
-	GENL [f,g] (IMP_ANTISYM_RULE imp1 imp2)
-    end;
-
-val _ = save_thm("EXISTS_OR_THM",EXISTS_OR_THM);
-
-
-(* ------------------------------------------------------------------------- *)
-(* LEFT_OR_EXISTS_THM = |- (?x. P x) \/ Q = (?x. P x \/ Q)                   *)
-(* ------------------------------------------------------------------------- *)
-
-val LEFT_OR_EXISTS_THM =
-    let val x = (--`x:'a`--)
-	val Q = (--`Q:bool`--)
-	val f = (--`P:'a->bool`--)
-	val P = mk_comb(f,x)
-	val ep = mk_exists(x,P)
-	val tm = mk_disj(ep,Q)
-	val otm = mk_exists(x,mk_disj(P,Q))
-	val t1 = DISJ1 (ASSUME P) Q
-        val t2 = DISJ2 P (ASSUME Q)
-	val th1 = EXISTS(otm,x) t1 and th2 = EXISTS(otm,x) t2
-	val thm1 = DISJ_CASES (ASSUME tm) (CHOOSE(x,ASSUME ep)th1) th2
-	val imp1 = DISCH tm thm1
-	val Pth = EXISTS(ep,x)(ASSUME P) and Qth = ASSUME Q
-	val thm2 = DISJ_CASES_UNION (ASSUME(mk_disj(P,Q))) Pth Qth
-	val imp2 = DISCH otm (CHOOSE (x,ASSUME otm) thm2)
-    in
-	GENL [f,Q] (IMP_ANTISYM_RULE imp1 imp2)
-    end;
-
-val _ = save_thm("LEFT_OR_EXISTS_THM",LEFT_OR_EXISTS_THM);
-
-
-(* ------------------------------------------------------------------------- *)
-(* RIGHT_OR_EXISTS_THM = |- P \/ (?x. Q x) = (?x. P \/ Q x)                  *)
-(* ------------------------------------------------------------------------- *)
-
-val RIGHT_OR_EXISTS_THM =
-    let	val x = (--`x:'a`--)
-	val P = (--`P:bool`--)
-	val g = (--`Q:'a->bool`--)
-	val Q = mk_comb(g,x)
-	val eq = mk_exists(x,Q)
-	val tm = mk_disj(P,eq)
-	val otm = mk_exists(x,mk_disj(P,Q))
-	val t1 = DISJ1 (ASSUME P) Q and t2 = DISJ2 P (ASSUME Q)
-	val th1 = EXISTS(otm,x) t1 and th2 = EXISTS(otm,x) t2
-	val thm1 = DISJ_CASES (ASSUME tm) th1 (CHOOSE(x,ASSUME eq)th2)
-	val imp1 = DISCH tm thm1
-	val Qth = EXISTS(eq,x)(ASSUME Q) and Pth = ASSUME P
-	val thm2 = DISJ_CASES_UNION (ASSUME(mk_disj(P,Q))) Pth Qth
-	val imp2 = DISCH otm (CHOOSE (x,ASSUME otm)  thm2)
-    in
-	    GENL [P,g] (IMP_ANTISYM_RULE imp1 imp2)
-    end;
-
-val _ = save_thm("RIGHT_OR_EXISTS_THM",RIGHT_OR_EXISTS_THM);
-
-
-(* ------------------------------------------------------------------------- *)
-(* BOTH_EXISTS_AND_THM = |- !P Q. (?x. P /\ Q) = (?x. P) /\ (?x. Q)          *)
-(* ------------------------------------------------------------------------- *)
-
-val BOTH_EXISTS_AND_THM =
-    let	val x = (--`x:'a`--)
-	val P = (--`P:bool`--)
-	val Q = (--`Q:bool`--)
-	val t = mk_conj(P,Q)
-	val exi = mk_exists(x,t)
-	val (t1,t2) = CONJ_PAIR (ASSUME t)
-	val t11 = EXISTS ((mk_exists(x,P)),x) t1
-	val t21 = EXISTS ((mk_exists(x,Q)),x) t2
-	val imp1 = DISCH_ALL (CHOOSE (x,
-                    ASSUME (mk_exists(x,mk_conj(P,Q))))
-		   (CONJ t11 t21))
-	val th21 = EXISTS (exi,x) (CONJ (ASSUME P) (ASSUME Q))
-	val th22 = CHOOSE(x,ASSUME(mk_exists(x,P))) th21
-	val th23 = CHOOSE(x,ASSUME(mk_exists(x,Q))) th22
-	val (u1,u2) =
-	    CONJ_PAIR (ASSUME (mk_conj(mk_exists(x,P),mk_exists(x,Q))))
-	val th24 = PROVE_HYP u1 (PROVE_HYP u2 th23)
-	val imp2 = DISCH_ALL th24
-    in
-	GENL [P,Q] (IMP_ANTISYM_RULE imp1 imp2)
-    end;
-
-val _ = save_thm("BOTH_EXISTS_AND_THM",BOTH_EXISTS_AND_THM);
-
-(* ------------------------------------------------------------------------- *)
-(* LEFT_EXISTS_AND_THM = |- !P Q. (?x. P x /\ Q) = (?x. P x) /\ Q            *)
-(* ------------------------------------------------------------------------- *)
-
-val LEFT_EXISTS_AND_THM =
-    let val x = (--`x:'a`--)
-	val f = (--`P:'a->bool`--)
-	val P = mk_comb(f,x)
-	val Q = (--`Q:bool`--)
-	val t = mk_conj(P,Q)
-	val exi = mk_exists(x,t)
-	val (t1,t2) = CONJ_PAIR (ASSUME t)
-	val t11 = EXISTS ((mk_exists(x,P)),x) t1
-	val imp1 =
-	    DISCH_ALL
-		(CHOOSE
-		 (x, ASSUME (mk_exists(x,mk_conj(P,Q))))
-		    (CONJ t11 t2))
-	val th21 = EXISTS (exi,x) (CONJ (ASSUME P) (ASSUME Q))
-	val th22 = CHOOSE(x,ASSUME(mk_exists(x,P))) th21
-	val (u1,u2) = CONJ_PAIR(ASSUME(mk_conj(mk_exists(x,P), Q)))
-	val th23 = PROVE_HYP u1 (PROVE_HYP u2 th22)
-	val imp2 = DISCH_ALL th23
-    in
-	GENL [f,Q] (IMP_ANTISYM_RULE imp1 imp2)
-    end ;
-
-val _ = save_thm("LEFT_EXISTS_AND_THM",LEFT_EXISTS_AND_THM);
-
-(* ------------------------------------------------------------------------- *)
-(* RIGHT_EXISTS_AND_THM = |- !P Q. (?x. P /\ Q x) = P /\ (?x. Q x)           *)
-(* ------------------------------------------------------------------------- *)
-
-val RIGHT_EXISTS_AND_THM =
-    let	val x = (--`x:'a`--)
-	val P = (--`P:bool`--)
-	val g = (--`Q:'a->bool`--)
-	val Q = mk_comb(g,x)
-	val t = mk_conj(P,Q)
-	val exi = mk_exists(x,t)
-	val (t1,t2) = CONJ_PAIR (ASSUME t)
-	val t21 = EXISTS ((mk_exists(x,Q)),x) t2
-	val imp1 =
-	    DISCH_ALL
-		(CHOOSE
-		 (x, ASSUME (mk_exists(x,mk_conj(P,Q)))) (CONJ t1 t21))
-	val th21 = EXISTS (exi,x) (CONJ (ASSUME P) (ASSUME Q))
-	val th22 = CHOOSE(x,ASSUME(mk_exists(x,Q))) th21
-	val (u1,u2) = CONJ_PAIR (ASSUME (mk_conj(P, mk_exists(x,Q))))
-	val th23 = PROVE_HYP u1 (PROVE_HYP u2 th22)
-	val imp2 = DISCH_ALL th23
-    in
-	GENL [P,g] (IMP_ANTISYM_RULE imp1 imp2)
-    end;
-
-val _ = save_thm("RIGHT_EXISTS_AND_THM",RIGHT_EXISTS_AND_THM);
-
-
-(* ------------------------------------------------------------------------- *)
-(* BOTH_FORALL_OR_THM = |- !P Q. (!x. P \/ Q) = (!x. P) \/ (!x. Q)           *)
-(* ------------------------------------------------------------------------- *)
-
-val BOTH_FORALL_OR_THM =
-  let val x = (--`x:'a`--)
-      val P = (--`P:bool`--)
-      val Q = (--`Q:bool`--)
-      val imp11 = DISCH_ALL (SPEC x (ASSUME (mk_forall(x,P))))
-      val imp12 = DISCH_ALL (GEN x (ASSUME P))
-      val fath = IMP_ANTISYM_RULE imp11 imp12
-      val th1 = REFL (mk_forall(x,mk_disj(P,Q)))
-      val th2 = CONV_RULE (RAND_CONV
-                 (K (INST [P |-> mk_disj(P,Q)] fath))) th1
-      val th3 = CONV_RULE(RAND_CONV(RATOR_CONV(RAND_CONV(K(SYM fath))))) th2
-      val th4 = CONV_RULE(RAND_CONV(RAND_CONV(K(SYM(INST[P|->Q] fath))))) th3
-  in
-    GENL [P,Q] th4
-  end;
-
-val _ = save_thm("BOTH_FORALL_OR_THM",BOTH_FORALL_OR_THM);
-
-(* ------------------------------------------------------------------------- *)
-(* LEFT_FORALL_OR_THM = |- !P Q. (!x. P x \/ Q) = (!x. P x) \/ Q             *)
-(* ------------------------------------------------------------------------- *)
-
-val LEFT_FORALL_OR_THM =
-  let val x = (--`x:'a`--)
-      val f = (--`P:'a->bool`--)
-      val P = mk_comb(f,x)
-      val Q = (--`Q:bool`--)
-      val tm = mk_forall(x,mk_disj(P,Q))
-      val thm1 = SPEC x (ASSUME tm)
-      val thm2 = CONTR P (MP (ASSUME (mk_neg Q)) (ASSUME Q))
-      val thm3 = DISJ1 (GEN x (DISJ_CASES thm1 (ASSUME P) thm2)) Q
-      val thm4 = DISJ2 (mk_forall(x,P)) (ASSUME Q)
-      val imp1 = DISCH tm (DISJ_CASES (SPEC Q EXCLUDED_MIDDLE) thm4 thm3)
-      val thm5 = SPEC x (ASSUME (mk_forall(x,P)))
-      val thm6 = ASSUME Q
-      val imp2 = DISCH_ALL (GEN x (DISJ_CASES_UNION
-                  (ASSUME(mk_disj(mk_forall(x,P), Q))) thm5 thm6))
-  in
-      GENL [Q,f] (IMP_ANTISYM_RULE imp1 imp2)
-  end;
-
-val _ = save_thm("LEFT_FORALL_OR_THM",LEFT_FORALL_OR_THM);
-
-(* ------------------------------------------------------------------------- *)
-(* RIGHT_FORALL_OR_THM = |- !P Q. (!x. P \/ Q x) = P \/ (!x. Q x)            *)
-(* ------------------------------------------------------------------------- *)
-
-val RIGHT_FORALL_OR_THM =
-    let	val x = (--`x:'a`--)
-	val P = (--`P:bool`--)
-	val g = (--`Q:'a->bool`--)
-	val Q = mk_comb(g,x)
-	val tm   = mk_forall(x,mk_disj(P,Q))
-	val thm1 = SPEC x (ASSUME tm)
-	val thm2 = CONTR Q (MP (ASSUME (mk_neg P)) (ASSUME P))
-	val thm3 = DISJ2 P (GEN x (DISJ_CASES thm1 thm2 (ASSUME Q)))
-	val thm4 = DISJ1 (ASSUME P) (mk_forall(x,Q))
-	val imp1 = DISCH tm (DISJ_CASES (SPEC P EXCLUDED_MIDDLE) thm4 thm3)
-	val thm5 = ASSUME P
-	val thm6 = SPEC x (ASSUME (mk_forall(x,Q)))
-	val imp2 = DISCH_ALL (GEN x (DISJ_CASES_UNION
-                   (ASSUME (mk_disj(P, mk_forall(x,Q))))
-                   thm5 thm6))
-    in
-	    GENL [P,g] (IMP_ANTISYM_RULE imp1 imp2)
-    end;
-
-val _ = save_thm("RIGHT_FORALL_OR_THM",RIGHT_FORALL_OR_THM);
-
-
-(* ------------------------------------------------------------------------- *)
-(* BOTH_FORALL_IMP_THM = |- (!x. P ==> Q) = ((?x.P) ==> (!x.Q))              *)
-(* ------------------------------------------------------------------------- *)
-
-val BOTH_FORALL_IMP_THM =
-    let val x = (--`x:'a`--)
-	val P = (--`P:bool`--)
-	val Q = (--`Q:bool`--)
-	val tm = mk_forall(x, mk_imp(P,Q))
-	val asm = mk_exists(x,P)
-	val th1 = GEN x (CHOOSE(x,ASSUME asm)(UNDISCH(SPEC x (ASSUME tm))))
-	val imp1 = DISCH tm (DISCH asm th1)
-	val cncl = rand(concl imp1)
-	val th2 = SPEC x (MP (ASSUME cncl) (EXISTS (asm,x) (ASSUME P)))
-	val imp2 = DISCH cncl (GEN x (DISCH P th2))
-    in
-	GENL [P,Q] (IMP_ANTISYM_RULE imp1 imp2)
-    end;
-
-val _ = save_thm("BOTH_FORALL_IMP_THM",BOTH_FORALL_IMP_THM);
-
-
-(* ------------------------------------------------------------------------- *)
-(* LEFT_FORALL_IMP_THM = |- (!x. P[x]==>Q) = ((?x.P[x]) ==> Q)               *)
-(* ------------------------------------------------------------------------- *)
-
-val LEFT_FORALL_IMP_THM =
-    let	val x = (--`x:'a`--)
-	val f = (--`P:'a->bool`--)
-	val P = mk_comb(f,x)
-	val Q = (--`Q:bool`--)
-	val tm = mk_forall(x, mk_imp(P,Q))
-	val asm = mk_exists(x,P)
-	val th1 = CHOOSE(x,ASSUME asm)(UNDISCH(SPEC x (ASSUME tm)))
-	val imp1 = DISCH tm (DISCH asm th1)
-	val cncl = rand(concl imp1)
-	val th2 = MP (ASSUME cncl) (EXISTS (asm,x) (ASSUME P))
-	val imp2 = DISCH cncl (GEN x (DISCH P th2))
-    in
-	GENL [f,Q] (IMP_ANTISYM_RULE imp1 imp2)
-    end;
-
-val _ = save_thm("LEFT_FORALL_IMP_THM",LEFT_FORALL_IMP_THM);
-
-(* ------------------------------------------------------------------------- *)
-(* RIGHT_FORALL_IMP_THM = |- (!x. P==>Q[x]) = (P ==> (!x.Q[x]))              *)
-(* ------------------------------------------------------------------------- *)
-
-val RIGHT_FORALL_IMP_THM =
-    let val x = (--`x:'a`--)
-	val P = (--`P:bool`--)
-	val g = (--`Q:'a->bool`--)
-	val Q = mk_comb(g,x)
-	val tm = mk_forall(x, mk_imp(P,Q))
-	val imp1 = DISCH P(GEN x(UNDISCH(SPEC x(ASSUME tm))))
-	val cncl = concl imp1
-	val imp2 = GEN x (DISCH P(SPEC x(UNDISCH (ASSUME cncl))))
-    in
-	GENL [P,g] (IMP_ANTISYM_RULE (DISCH tm imp1) (DISCH cncl imp2))
-    end;
-
-val _ = save_thm("RIGHT_FORALL_IMP_THM",RIGHT_FORALL_IMP_THM);
-
-
-(* ------------------------------------------------------------------------- *)
-(* BOTH_EXISTS_IMP_THM = |- (?x. P ==> Q) = ((!x.P) ==> (?x.Q))              *)
-(* ------------------------------------------------------------------------- *)
-
-val BOTH_EXISTS_IMP_THM =
-    let val x = (--`x:'a`--)
-	val P = (--`P:bool`--)
-	val Q = (--`Q:bool`--)
-	val tm = mk_exists(x,mk_imp(P,Q))
-	val eQ = mk_exists(x,Q)
-	val aP = mk_forall(x,P)
-	val thm1 = EXISTS(eQ,x)(UNDISCH(ASSUME(mk_imp(P,Q))))
-	val thm2 = DISCH aP (PROVE_HYP (SPEC x (ASSUME aP)) thm1)
-	val imp1 = DISCH tm (CHOOSE(x,ASSUME tm) thm2)
-	val thm2 = CHOOSE(x,UNDISCH (ASSUME (rand(concl imp1)))) (ASSUME Q)
-	val thm3 = DISCH P (PROVE_HYP (GEN x (ASSUME P)) thm2)
-	val imp2 = DISCH (rand(concl imp1)) (EXISTS(tm,x) thm3)
-    in
-	GENL [P,Q] (IMP_ANTISYM_RULE imp1 imp2)
-    end;
-
-val _ = save_thm("BOTH_EXISTS_IMP_THM",BOTH_EXISTS_IMP_THM);
-
-
-(* ------------------------------------------------------------------------- *)
-(* LEFT_EXISTS_IMP_THM = |- (?x. P[x] ==> Q) = ((!x.P[x]) ==> Q)             *)
-(* ------------------------------------------------------------------------- *)
-
-val LEFT_EXISTS_IMP_THM =
-    let	val x = (--`x:'a`--)
-	val f = (--`P:'a->bool`--)
-	val P = mk_comb(f,x)
-	val Q = (--`Q:bool`--)
-	val tm = mk_exists(x, mk_imp(P,Q))
-	val allp = mk_forall(x,P)
-	val th1 = SPEC x (ASSUME allp)
-	val thm1 = MP (ASSUME(mk_imp(P,Q))) th1
-	val imp1 = DISCH tm (CHOOSE(x,ASSUME tm)(DISCH allp thm1))
-	val otm = rand(concl imp1)
-	val thm2 = EXISTS(tm,x)(DISCH P (UNDISCH(ASSUME otm)))
-	val nex =  mk_exists(x,mk_neg P)
-	val asm1 = EXISTS (nex, x) (ASSUME (mk_neg P))
-	val th2 = CCONTR P (MP (ASSUME (mk_neg nex)) asm1)
-	val th3 = CCONTR nex (MP (ASSUME (mk_neg allp)) (GEN x th2))
-	val thm4 = DISCH P (CONTR Q (UNDISCH (ASSUME (mk_neg P))))
-	val thm5 = CHOOSE(x,th3)(EXISTS(tm,x)thm4)
-	val thm6 = DISJ_CASES (SPEC allp EXCLUDED_MIDDLE) thm2 thm5
-	val imp2 = DISCH otm thm6
-    in
-	GENL [f, Q] (IMP_ANTISYM_RULE imp1 imp2)
-    end;
-
-val _ = save_thm("LEFT_EXISTS_IMP_THM",LEFT_EXISTS_IMP_THM);
-
-
-(* ------------------------------------------------------------------------- *)
-(* RIGHT_EXISTS_IMP_THM = |- (?x. P ==> Q[x]) = (P ==> (?x.Q[x]))            *)
-(* ------------------------------------------------------------------------- *)
-
-val RIGHT_EXISTS_IMP_THM =
-    let	val x = (--`x:'a`--)
-	val P = (--`P:bool`--)
-	val g = (--`Q:'a->bool`--)
-	val Q = mk_comb(g,x)
-	val tm = mk_exists(x,mk_imp(P,Q))
-	val thm1 = EXISTS (mk_exists(x,Q),x)
-	                   (UNDISCH(ASSUME(mk_imp(P,Q))))
-	val imp1 = DISCH tm (CHOOSE(x,ASSUME tm) (DISCH P thm1))
-	val thm2 = UNDISCH (ASSUME (rand(concl imp1)))
-	val thm3 = CHOOSE (x,thm2) (EXISTS (tm,x) (DISCH P (ASSUME Q)))
-	val thm4 = EXISTS(tm,x)(DISCH P(CONTR Q(UNDISCH(ASSUME(mk_neg P)))))
-	val thm5 = DISJ_CASES (SPEC P EXCLUDED_MIDDLE) thm3 thm4
-	val imp2 = DISCH(rand(concl imp1)) thm5
-    in
-	GENL [P,g] (IMP_ANTISYM_RULE imp1 imp2)
-    end;
-
-val _ = save_thm("RIGHT_EXISTS_IMP_THM",RIGHT_EXISTS_IMP_THM);
-
-(* --------------------------------------------------------------------- *)
-(* OR_IMP_THM = |- !A B. (A = B \/ A) = (B ==> A)                        *)
-(* [TFM 90.06.28]                                                        *)
-(* --------------------------------------------------------------------- *)
-
-val OR_IMP_THM =
- let val t1 = (--`A:bool`--) and t2 = (--`B:bool`--)
-     val asm1 = ASSUME (--`^t1 = (^t2 \/ ^t1)`--)
-     and asm2 = EQT_INTRO(ASSUME t2)
-     val th1 = SUBST [t2 |-> asm2] (concl asm1) asm1
-     val th2 = TRANS th1 (CONJUNCT1 (SPEC t1 OR_CLAUSES))
-     val imp1 = DISCH (concl asm1) (DISCH t2 (EQT_ELIM th2))
-     val asm3 = ASSUME (--`^t2 ==> ^t1`--)
-     and asm4 = ASSUME (--`^t2 \/ ^t1`--)
-     val th3 = DISJ_CASES asm4 (MP asm3 (ASSUME t2)) (ASSUME t1)
-     val th4 = DISCH (concl asm4) th3
-     and th5 = DISCH t1 (DISJ2 t2 (ASSUME t1))
-     val imp2 = DISCH (--`^t2 ==> ^t1`--) (IMP_ANTISYM_RULE th5 th4)
-  in
-   GEN t1 (GEN t2 (IMP_ANTISYM_RULE imp1 imp2))
-  end;
-
-val _ = save_thm("OR_IMP_THM",OR_IMP_THM);
-
-(* --------------------------------------------------------------------- *)
-(* NOT_IMP = |- !A B. ~(A ==> B) = A /\ ~B                               *)
-(* [TFM 90.07.09]                                                        *)
-(* --------------------------------------------------------------------- *)
-
-val NOT_IMP =
-let val t1 = (--`A:bool`--) and t2 = (--`B:bool`--)
-    val asm1 = ASSUME (--`~(^t1 ==> ^t2)`--)
-    val thm1 = SUBST [t1 |-> EQF_INTRO (ASSUME (mk_neg t1))] (concl asm1) asm1
-    val thm2 = CCONTR t1 (MP thm1 (DISCH(--`F`--)(CONTR t2 (ASSUME(--`F`--)))))
-    val thm3 = SUBST [t2 |-> EQT_INTRO (ASSUME t2)] (concl asm1) asm1
-    val thm4 = NOT_INTRO(DISCH t2 (MP thm3 (DISCH t1 (ADD_ASSUM t1 TRUTH))))
-    val imp1 = DISCH (concl asm1) (CONJ thm2 thm4)
-    val conj =  ASSUME (--`^t1 /\ ~^t2`--)
-    val (asm2,asm3) = (CONJUNCT1 conj, CONJUNCT2 conj)
-    val asm4 = ASSUME (--`^t1 ==> ^t2`--)
-    val thm5 = MP (SUBST [t2 |-> EQF_INTRO asm3] (concl asm4) asm4) asm2
-    val imp2 = DISCH (--`^t1 /\ ~ ^t2`--)
-                     (NOT_INTRO(DISCH (--`^t1 ==> ^t2`--) thm5))
- in
-    GEN t1 (GEN t2 (IMP_ANTISYM_RULE imp1 imp2))
- end;
-
-val _ = save_thm("NOT_IMP", NOT_IMP);
-
-(* --------------------------------------------------------------------- *)
-(* DISJ_ASSOC: |- !A B C. A \/ B \/ C = (A \/ B) \/ C                    *)
-(* --------------------------------------------------------------------- *)
-
-val DISJ_ASSOC =
-let val t1 = (--`A:bool`--) and t2 = (--`B:bool`--) and t3 = (--`C:bool`--)
-    val at1 = DISJ1 (DISJ1 (ASSUME t1) t2) t3 and
-        at2 = DISJ1 (DISJ2 t1 (ASSUME t2)) t3 and
-        at3 = DISJ2 (mk_disj(t1,t2)) (ASSUME t3)
-    val thm = DISJ_CASES (ASSUME (mk_disj(t2,t3))) at2 at3
-    val thm1 = DISJ_CASES (ASSUME (mk_disj(t1,mk_disj(t2,t3)))) at1 thm
-    val at1 = DISJ1 (ASSUME t1) (mk_disj(t2,t3)) and
-        at2 = DISJ2 t1 (DISJ1 (ASSUME t2) t3) and
-        at3 = DISJ2 t1 (DISJ2 t2 (ASSUME t3))
-    val thm = DISJ_CASES (ASSUME (mk_disj(t1,t2))) at1 at2
-    val thm2 = DISJ_CASES (ASSUME (mk_disj(mk_disj(t1,t2),t3))) thm at3
-    val imp1 = DISCH (mk_disj(t1,mk_disj(t2,t3))) thm1 and
-        imp2 = DISCH (mk_disj(mk_disj(t1,t2),t3)) thm2
- in
-   GENL [t1,t2,t3] (IMP_ANTISYM_RULE imp1 imp2)
- end;
-
-val _ = save_thm("DISJ_ASSOC", DISJ_ASSOC);
-
-(* --------------------------------------------------------------------- *)
-(* DISJ_SYM: |- !A B. A \/ B = B \/ A                   		 *)
-(* --------------------------------------------------------------------- *)
-
-val DISJ_SYM =
-let val t1   = (--`A:bool`--) and t2 = (--`B:bool`--)
-    val th1  = DISJ1 (ASSUME t1) t2 and th2 = DISJ2 t1 (ASSUME t2)
-    val thm1 = DISJ_CASES (ASSUME(mk_disj(t2,t1))) th2 th1
-    val th1  = DISJ1 (ASSUME t2) t1 and th2 = DISJ2 t2 (ASSUME t1)
-    val thm2 = DISJ_CASES (ASSUME(mk_disj(t1,t2))) th2 th1
-    val imp1 = DISCH (mk_disj(t2,t1)) thm1 and
-        imp2 = DISCH (mk_disj(t1,t2)) thm2
- in
-   GENL [t1,t2] (IMP_ANTISYM_RULE imp2 imp1)
- end;
-
-val _ = save_thm("DISJ_SYM", DISJ_SYM);
-val _ = save_thm("DISJ_COMM", DISJ_SYM);
-
-(* --------------------------------------------------------------------- *)
-(* DE_MORGAN_THM: 							 *)
-(*  |- !A B. (~(t1 /\ t2) = ~t1 \/ ~t2) /\ (~(t1 \/ t2) = ~t1 /\ ~t2)    *)
-(* --------------------------------------------------------------------- *)
-
-val DE_MORGAN_THM =
-let val t1 = (--`A:bool`--) and t2 = (--`B:bool`--)
-    val thm1 =
-      let val asm1 = ASSUME (--`~(^t1 /\ ^t2)`--)
-          val cnj = MP asm1 (CONJ (ASSUME t1) (ASSUME t2))
-          val imp1 =
-            let val case1 = DISJ2 (--`~^t1`--) (NOT_INTRO(DISCH t2 cnj))
-                val case2 = DISJ1 (ASSUME (--`~ ^t1`--)) (--`~ ^t2`--)
-            in DISJ_CASES (SPEC t1 EXCLUDED_MIDDLE) case1 case2
-            end
-          val th1 = MP (ASSUME (--`~^t1`--))
-                       (CONJUNCT1 (ASSUME (--`^t1 /\ ^t2`--)))
-          val th2 = MP (ASSUME (--`~^t2`--))
-                   (CONJUNCT2 (ASSUME (--`^t1 /\ ^t2`--)))
-          val imp2 =
-            let val fth = DISJ_CASES (ASSUME (--`~^t1 \/ ~^t2`--)) th1 th2
-            in DISCH (--`~^t1 \/ ~^t2`--)
-                     (NOT_INTRO(DISCH (--`^t1 /\ ^t2`--) fth))
-            end
-      in
-        IMP_ANTISYM_RULE (DISCH (--`~(^t1 /\ ^t2)`--) imp1) imp2
-      end
-    val thm2 =
-      let val asm1 = ASSUME (--`~(^t1 \/ ^t2)`--)
-          val imp1 =
-            let val th1 = NOT_INTRO (DISCH t1(MP asm1 (DISJ1 (ASSUME t1) t2)))
-                val th2 = NOT_INTRO (DISCH t2 (MP asm1 (DISJ2 t1 (ASSUME t2))))
-            in DISCH (--`~(^t1 \/ ^t2)`--) (CONJ th1 th2)
-            end
-          val imp2 =
-            let val asm = ASSUME (--`^t1 \/ ^t2`--)
-                val a1 = CONJUNCT1(ASSUME (--`~^t1 /\ ~^t2`--)) and
-                    a2 = CONJUNCT2(ASSUME (--`~^t1 /\ ~^t2`--))
-               val fth = DISJ_CASES asm (UNDISCH a1) (UNDISCH a2)
-            in DISCH (--`~^t1 /\ ~^t2`--)
-                    (NOT_INTRO(DISCH (--`^t1 \/ ^t2`--) fth))
-            end
-      in IMP_ANTISYM_RULE imp1 imp2
-      end
- in GEN t1 (GEN t2 (CONJ thm1 thm2))
- end;
-
-val _ = save_thm("DE_MORGAN_THM", DE_MORGAN_THM);
-
-(* -------------------------------------------------------------------------*)
-(* Distributive laws:							    *)
-(*									    *)
-(* LEFT_AND_OVER_OR   |- !A B C. A /\ (B \/ C) = A /\ B \/ A /\ C           *)
-(*									    *)
-(* RIGHT_AND_OVER_OR  |- !A B C. (B \/ C) /\ A = B /\ A \/ C /\ A           *)
-(*									    *)
-(* LEFT_OR_OVER_AND   |- !A B C. A \/ B /\ C = (A \/ B) /\ (A \/ C)         *)
-(*									    *)
-(* RIGHT_OR_OVER_AND  |- !A B C. B /\ C \/ A = (B \/ A) /\ (C \/ A)         *)
-(* -------------------------------------------------------------------------*)
-
-val LEFT_AND_OVER_OR =
-    let val t1 = --`A:bool`--
-        and t2 = --`B:bool`--
-        and t3 = --`C:bool`--
-        val (th1,th2) = CONJ_PAIR(ASSUME (mk_conj(t1,mk_disj(t2,t3))))
-        val th3 = CONJ th1 (ASSUME t2) and th4 = CONJ th1 (ASSUME t3)
-        val th5 = DISJ_CASES_UNION th2 th3 th4
-        val imp1 = DISCH (mk_conj(t1,mk_disj(t2,t3))) th5
-        val (th1,th2) = (I ## C DISJ1 t3) (CONJ_PAIR (ASSUME (mk_conj(t1,t2))))
-        val (th3,th4) = (I ## DISJ2 t2) (CONJ_PAIR (ASSUME (mk_conj(t1,t3))))
-        val th5 = CONJ th1 th2 and th6 = CONJ th3 th4
-        val th6 = DISJ_CASES (ASSUME (rand(concl imp1))) th5 th6
-        val imp2 = DISCH (rand(concl imp1)) th6
-    in
-      GEN t1 (GEN t2 (GEN t3 (IMP_ANTISYM_RULE imp1 imp2)))
-    end;
-
-val _ = save_thm("LEFT_AND_OVER_OR", LEFT_AND_OVER_OR);
-
-val RIGHT_AND_OVER_OR =
-   let val t1 = --`A:bool`--
-       and t2 = --`B:bool`--
-       and t3 = --`C:bool`--
-       val (th1,th2) = CONJ_PAIR(ASSUME (mk_conj(mk_disj(t2,t3),t1)))
-       val th3 = CONJ (ASSUME t2) th2 and th4 = CONJ (ASSUME t3) th2
-       val th5 = DISJ_CASES_UNION th1 th3 th4
-       val imp1 = DISCH (mk_conj(mk_disj(t2,t3),t1)) th5
-       val (th1,th2) = (C DISJ1 t3 ## I) (CONJ_PAIR (ASSUME (mk_conj(t2,t1))))
-       val (th3,th4) = (DISJ2 t2 ## I) (CONJ_PAIR (ASSUME (mk_conj(t3,t1))))
-       val th5 = CONJ th1 th2 and th6 = CONJ th3 th4
-       val th6 = DISJ_CASES (ASSUME (rand(concl imp1))) th5 th6
-       val imp2 = DISCH (rand(concl imp1)) th6
-   in
-     GEN t1 (GEN t2 (GEN t3 (IMP_ANTISYM_RULE imp1 imp2)))
-   end;
-
-val _ = save_thm("RIGHT_AND_OVER_OR", RIGHT_AND_OVER_OR);
-
-val LEFT_OR_OVER_AND =
-   let val t1 = --`A:bool`--
-       and t2 = --`B:bool`--
-       and t3 = --`C:bool`--
-       val th1 = ASSUME (mk_disj(t1,mk_conj(t2,t3)))
-       val th2 = CONJ (DISJ1 (ASSUME t1) t2) (DISJ1 (ASSUME t1) t3)
-       val (th3,th4) = CONJ_PAIR (ASSUME(mk_conj(t2,t3)))
-       val th5 = CONJ (DISJ2 t1 th3) (DISJ2 t1 th4)
-       val imp1 = DISCH (concl th1) (DISJ_CASES th1 th2 th5)
-       val (th1,th2) = CONJ_PAIR (ASSUME (rand(concl imp1)))
-       val th3 = DISJ1 (ASSUME t1) (mk_conj(t2,t3))
-       val (th4,th5) = CONJ_PAIR (ASSUME (mk_conj(t2,t3)))
-       val th4 = DISJ2 t1 (CONJ (ASSUME t2) (ASSUME t3))
-       val th5 = DISJ_CASES th2 th3 (DISJ_CASES th1 th3 th4)
-       val imp2 = DISCH (rand(concl imp1)) th5
-   in
-     GEN t1 (GEN t2 (GEN t3 (IMP_ANTISYM_RULE imp1 imp2)))
-   end;
-
-val _ = save_thm("LEFT_OR_OVER_AND", LEFT_OR_OVER_AND);
-
-val RIGHT_OR_OVER_AND =
-   let val t1 = --`A:bool`--
-       and t2 = --`B:bool`--
-       and t3 = --`C:bool`--
-       val th1 = ASSUME (mk_disj(mk_conj(t2,t3),t1))
-       val th2 = CONJ (DISJ2 t2 (ASSUME t1)) (DISJ2 t3 (ASSUME t1))
-       val (th3,th4) = CONJ_PAIR (ASSUME(mk_conj(t2,t3)))
-       val th5 = CONJ (DISJ1 th3 t1) (DISJ1 th4 t1)
-       val imp1 = DISCH (concl th1) (DISJ_CASES th1 th5 th2)
-       val (th1,th2) = CONJ_PAIR (ASSUME (rand(concl imp1)))
-       val th3 = DISJ2 (mk_conj(t2,t3)) (ASSUME t1)
-       val (th4,th5) = CONJ_PAIR (ASSUME (mk_conj(t2,t3)))
-       val th4 = DISJ1 (CONJ (ASSUME t2) (ASSUME t3)) t1
-       val th5 = DISJ_CASES th2 (DISJ_CASES th1 th4 th3) th3
-       val imp2 = DISCH (rand(concl imp1)) th5
-   in
-     GEN t1 (GEN t2 (GEN t3 (IMP_ANTISYM_RULE imp1 imp2)))
-   end;
-
-val _ = save_thm("RIGHT_OR_OVER_AND", RIGHT_OR_OVER_AND);
-
-
-(*---------------------------------------------------------------------------*
- * IMP_DISJ_THM = |- !A B. A ==> B = ~A \/ B                                 *
- *---------------------------------------------------------------------------*)
-
-val IMP_DISJ_THM =
-let val A = --`A:bool`--
-    val B = --`B:bool`--
-    val th1 = ASSUME (Term`A ==> B`)
-    val th2 = ASSUME A
-    val th3 = MP th1 th2
-    val th4 = DISJ2 (Term`~A`) th3
-    val th5 = ASSUME (Term`~A`);
-    val th6 = ADD_ASSUM (Term`A ==> B`) th5
-    val th7 = DISJ1 th6 B
-    val th8 = SPEC A EXCLUDED_MIDDLE
-    val th9 = DISJ_CASES th8 th4 th7
-
-    val th10 = EQT_INTRO th2
-    val th11 = ASSUME (Term`~A \/ B`)
-    val th12 = SUBST [A |-> th10] (concl th11) th11
-    val th13 = CONJUNCT1 (CONJUNCT2 NOT_CLAUSES)
-    val th14 = SUBST [A |-> th13] (subst [Term`~T` |-> A] (concl th12)) th12
-    val th15 = CONJUNCT1 (CONJUNCT2(CONJUNCT2 (SPEC B OR_CLAUSES)))
-    val th16 = SUBST [A |-> th15] A th14
-    val th17 = DISCH A th16
-    val th18 = DISCH (concl th11) th17
- in
-   GENL [A,B] (IMP_ANTISYM_RULE (DISCH (hd(hyp th9)) th9) th18)
- end;
-
-val _ = save_thm ("IMP_DISJ_THM", IMP_DISJ_THM);
-
-(*----------------------------------------------------------------------*)
-(* DISJ_IMP_THM = |- !P Q R. P \/ Q ==> R = (P ==> R) /\ (Q ==> R)      *)
-(*                                                         MN 99.05.06  *)
-(*----------------------------------------------------------------------*)
-
-val DISJ_IMP_THM = let
-  val P = --`P:bool`--
-  val Q = --`Q:bool`--
-  val R = --`R:bool`--
-  val lhs = --`P \/ Q ==> R`--
-  val rhs = --`(P ==> R) /\ (Q ==> R)`--
-  val ass_lhs = ASSUME lhs
-  val ass_P = ASSUME P
-  val ass_Q = ASSUME Q
-  val p_imp_r = DISCH P (MP ass_lhs (DISJ1 ass_P Q))
-  val q_imp_r = DISCH Q (MP ass_lhs (DISJ2 P ass_Q))
-  val lr_imp = DISCH lhs (CONJ p_imp_r q_imp_r)
-  (* half way there! *)
-  val ass_rhs = ASSUME rhs
-  val porq = (--`P \/ Q`--)
-  val ass_porq = ASSUME porq
-  val my_and1 = SPECL [(--`P ==> R`--), (--`Q ==> R`--)] AND1_THM
-  val p_imp_r = MP my_and1 ass_rhs
-  val r_from_p = MP p_imp_r ass_P
-  val my_and2 = SPECL [(--`P ==> R`--), (--`Q ==> R`--)] AND2_THM
-  val q_imp_r = MP my_and2 ass_rhs
-  val r_from_q = MP q_imp_r ass_Q
-  val rl_imp = DISCH rhs (DISCH porq (DISJ_CASES ass_porq r_from_p r_from_q))
-in
-  save_thm("DISJ_IMP_THM", GENL [P,Q,R] (IMP_ANTISYM_RULE lr_imp rl_imp))
-end
-
-(* ----------------------------------------------------------------------
-    IMP_CONJ_THM = |- !P Q R. P ==> Q /\ R = (P ==> Q) /\ (P ==> R)
-                                                          MN 2002.10.06
-   ---------------------------------------------------------------------- *)
-
-val IMP_CONJ_THM = let
-  val P = mk_var("P", bool)
-  val Q = mk_var("Q", bool)
-  val R = mk_var("R", bool)
-  val QandR = mk_conj(Q,R)
-  val PimpQandR = mk_imp(P, QandR)
-  val PiQaR_th = ASSUME PimpQandR
-  val P_th = ASSUME P
-  val QaR_th = MP PiQaR_th P_th
-  val (Q_th, R_th) = CONJ_PAIR QaR_th
-  val PQ_th = DISCH P Q_th
-  val PR_th = DISCH P R_th
-  val L2R = DISCH PimpQandR (CONJ PQ_th PR_th)
-  val PiQ = mk_imp(P, Q)
-  val PiR = mk_imp(P, R)
-  val PiQaPiR = mk_conj(PiQ, PiR)
-  val PiQaPiR_th = ASSUME PiQaPiR
-  val (PiQ_th, PiR_th) = CONJ_PAIR PiQaPiR_th
-  val Q_th = MP PiQ_th P_th
-  val R_th = MP PiR_th P_th
-  val QaR_th = CONJ Q_th R_th
-  val R2L = DISCH PiQaPiR (DISCH P QaR_th)
-in
-  save_thm("IMP_CONJ_THM", GENL [P,Q,R] (IMP_ANTISYM_RULE L2R R2L))
-end
-
-(* ---------------------------------------------------------------------*)
-(* IMP_F_EQ_F                                                           *)
-(*                                                                      *)
-(* |- !t. t ==> F = (t = F)					        *)
-(*				       	                   RJB 92.09.26 *)
-(* ---------------------------------------------------------------------*)
-local fun nthCONJUNCT n cth =
-        let val th = funpow (n-1) CONJUNCT2 cth
-        in if (can dest_conj (concl th))
-           then CONJUNCT1 th else th
-        end
-in
-val IMP_F_EQ_F =
-   GEN (--`t:bool`--)
-     (TRANS (nthCONJUNCT 5 (SPEC_ALL IMP_CLAUSES))
-            (SYM (nthCONJUNCT 4 (SPEC_ALL EQ_CLAUSES))))
-end;
-
-val _ = save_thm("IMP_F_EQ_F", IMP_F_EQ_F);
-
-(* ---------------------------------------------------------------------*)
-(* AND_IMP_INTRO							*)
-(*								        *)
-(* |- !t1 t2 t3. t1 ==> t2 ==> t3 = t1 /\ t2 ==> t3		        *)
-(*				       	                   RJB 92.09.26 *)
-(* ---------------------------------------------------------------------*)
-
-val AND_IMP_INTRO =
-let val t1 = --`t1:bool`--
-    and t2 = --`t2:bool`--
-    and t3 = --`t3:bool`--
-    and imp = --`$==>`--
-    val [IMP1,IMP2,IMP3,_,IMP4] = map GEN_ALL(CONJUNCTS (SPEC_ALL IMP_CLAUSES))
-    and [AND1,AND2,AND3,AND4,_] = map GEN_ALL(CONJUNCTS (SPEC_ALL AND_CLAUSES))
-    val thTl = SPEC (--`t2 ==> t3`--) IMP1
-    and thFl = SPEC (--`t2 ==> t3`--) IMP3
-    val thTr = AP_THM (AP_TERM imp (SPEC t2 AND1)) t3
-    and thFr = TRANS (AP_THM (AP_TERM imp (SPEC t2 AND3)) t3)(SPEC t3 IMP3)
-    val thT1 = TRANS thTl (SYM thTr)
-    and thF1 = TRANS thFl (SYM thFr)
-    val tm   = Term`t1 ==> t2 ==> t3 = t1 /\ t2 ==> t3`
-    val thT2 = SUBST_CONV [t1 |-> ASSUME (--`t1 = T`--)] tm tm
-    and thF2 = SUBST_CONV [t1 |-> ASSUME (--`t1 = F`--)] tm tm
-    val thT3 = EQ_MP (SYM thT2) thT1
-    and thF3 = EQ_MP (SYM thF2) thF1
- in
-   GENL [t1,t2,t3] (DISJ_CASES (SPEC t1 BOOL_CASES_AX) thT3 thF3)
- end;
-
-val _ = save_thm("AND_IMP_INTRO", AND_IMP_INTRO);
-
-(* ---------------------------------------------------------------------*)
-(* EQ_IMP_THM							        *)
-(*								        *)
-(* |- !t1 t2. (t1 = t2) = (t1 ==> t2) /\ (t2 ==> t1)		        *)
-(*								        *)
-(*				       	                   RJB 92.09.26 *)
-(* ---------------------------------------------------------------------*)
-
-val EQ_IMP_THM =
-let val t1 = --`t1:bool`--
-    and t2 = --`t2:bool`--
-    val conj = --`$/\`--
-    val [IMP1,IMP2,IMP3,_,IMP4] = map GEN_ALL(CONJUNCTS (SPEC_ALL IMP_CLAUSES))
-    and [AND1,AND2,AND3,AND4,_] = map GEN_ALL(CONJUNCTS (SPEC_ALL AND_CLAUSES))
-    and [EQ1,EQ2,EQ3,EQ4] = map GEN_ALL (CONJUNCTS (SPEC_ALL EQ_CLAUSES))
-    val thTl = SPEC t2 EQ1
-    and thFl = SPEC t2 EQ3
-    val thTr = TRANS (MK_COMB (AP_TERM conj (SPEC t2 IMP1), SPEC t2 IMP2))
-                     (SPEC t2 AND2)
-    and thFr = TRANS (MK_COMB (AP_TERM conj (SPEC t2 IMP3), SPEC t2 IMP4))
-                     (SPEC (mk_neg t2) AND1)
-    val thT1 = TRANS thTl (SYM thTr)
-    and thF1 = TRANS thFl (SYM thFr)
-    val tm = (--`(t1 = t2) = (t1 ==> t2) /\ (t2 ==> t1)`--)
-    val thT2 = SUBST_CONV [t1 |-> ASSUME (--`t1 = T`--)] tm tm
-    and thF2 = SUBST_CONV [t1 |-> ASSUME (--`t1 = F`--)] tm tm
-    val thT3 = EQ_MP (SYM thT2) thT1
-    and thF3 = EQ_MP (SYM thF2) thF1
- in

@@ Diff output truncated at 100000 characters. @@

This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 8874
          http://hol.svn.sourceforge.net/hol/?rev=8874&view=rev
Author:   xrchz
Date:     2011-01-15 23:25:12 +0000 (Sat, 15 Jan 2011)

Log Message:
-----------
Turns out last checkin was just a documentation bug

Modified Paths:
--------------
    HOL/help/Docfiles/Thm.INST_TYPE.doc
    HOL/src/1/selftest.sml

Modified: HOL/help/Docfiles/Thm.INST_TYPE.doc
===================================================================
--- HOL/help/Docfiles/Thm.INST_TYPE.doc	2011-01-15 23:04:33 UTC (rev 8873)
+++ HOL/help/Docfiles/Thm.INST_TYPE.doc	2011-01-15 23:25:12 UTC (rev 8874)
@@ -19,12 +19,11 @@
     |- 
    t[ty1,...,tyn/vty1,...,vtyn]
 }
-Type substitution is performed throughout the hypotheses
-and the conclusion,. Variables will be renamed if necessary to prevent
-distinct variables becoming identical after the instantiation.
+Type substitution is performed throughout the hypotheses and
+the conclusion. Variables will be renamed if necessary to
+prevent distinct bound variables becoming identical after
+the instantiation.
 
-
-
 \FAILURE
 Never fails.
 

Modified: HOL/src/1/selftest.sml
===================================================================
--- HOL/src/1/selftest.sml	2011-01-15 23:04:33 UTC (rev 8873)
+++ HOL/src/1/selftest.sml	2011-01-15 23:25:12 UTC (rev 8874)
@@ -105,21 +105,6 @@
   if aconv (concl Falsity) F then die "FAILED!" else die "Huh???"
 end handle ExitOK => print "OK\n"
 
-(* Test for INST_TYPE bug discovered here
-http://www.gilith.com/pipermail/opentheory-users/2011-January/000083.html *)
-val _ = let
-  val _ = tprint "Testing for INST_TYPE variable renaming bug"
-  val va = mk_var("v", alpha)
-  val vb = mk_var("v", bool)
-  val tm = mk_comb(mk_comb(mk_abs(va,mk_abs(vb,T)),va),vb)
-  val th = EQ_MP (SYM (DEPTH_CONV BETA_CONV tm)) TRUTH
-  val (_,[v1,v2]) = strip_comb (concl th)
-  val _ = if v1 = v2 then die "Huh???" else ()
-  val th = INST_TYPE [alpha|->bool] th
-  val (_,[v1,v2]) = strip_comb (concl th)
-  val _ = if v1 = v2 then die "FAILED!" else ()
-in () end
-
 val _ = Process.atExit (fn () => let
                              fun rm s = FileSys.remove s
                                         handle _ => ()


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 8898
          http://hol.svn.sourceforge.net/hol/?rev=8898&view=rev
Author:   michaeln
Date:     2011-01-28 00:57:41 +0000 (Fri, 28 Jan 2011)

Log Message:
-----------
Implement & document nodollarparens option for the TeX munger.

Modified Paths:
--------------
    HOL/Manual/Description/misc.tex
    HOL/src/TeX/mkmunger.sml
    HOL/src/TeX/mungeTools.sml

Modified: HOL/Manual/Description/misc.tex
===================================================================
--- HOL/Manual/Description/misc.tex	2011-01-28 00:57:08 UTC (rev 8897)
+++ HOL/Manual/Description/misc.tex	2011-01-28 00:57:41 UTC (rev 8898)
@@ -893,6 +893,17 @@
 %
 In this way, large complicated terms that are not themselves theorems (or even of boolean type), can be stored in \HOL{} theories, and then printed in \LaTeX{} documents.
 
+\item[\texttt{nodollarparens}] (For use with \holtm{} and \holthm.) Causes the default escaping of syntactic sugar to be suppressed.
+\index{ escape, in HOL logic parser@...{\$} (escape, in \HOL{} logic parser)}%
+\index{tokens!suppressing parsing behaviour of}
+The default behaviour is to use parentheses, so that
+\begin{verbatim}
+   \HOLtm{$/\ p}
+\end{verbatim}
+would get printed as $(\land)\;\,p$.
+Note that this doesn't reflect the default behaviour in the interactive loop, which is to use dollar-signs (as in the input above); see Section~\ref{sec:parser:architecture}.
+However, with the \texttt{nodollarparens} option specified, nothing at all is printed to indicate that the special syntax has been ``escaped''.
+
 \item[\texttt{nosp}] (Only for use with \holthm.)
 %
 By default, arguments to \holthm{} are fully specialised (\ie, they have \ml{SPEC\_ALL} applied to them), removing outermost universal quantifiers.

Modified: HOL/src/TeX/mkmunger.sml
===================================================================
--- HOL/src/TeX/mkmunger.sml	2011-01-28 00:57:08 UTC (rev 8897)
+++ HOL/src/TeX/mkmunger.sml	2011-01-28 00:57:41 UTC (rev 8898)
@@ -5,7 +5,7 @@
   val () = Feedback.emit_MESG := false
   val () = Feedback.WARNING_outstream := TextIO.stdErr
   val () = set_trace "Unicode" 1
-  val () = set_trace "pp_dollar_escapes" 0
+  val () = set_trace "pp_dollar_escapes" 1
   val () = set_trace "ambiguous grammar warning" 2
   open TextIO
   val lexer = mungeLex.makeLexer (fn n => TextIO.input stdIn)
@@ -22,7 +22,7 @@
   fun setoverrides s = mungeTools.user_overrides := mungeTools.read_overrides s
   val run_lexer = ref true
   val _ = case CommandLine.arguments() of
-            [] => () 
+            [] => ()
           | ["-index", basename] => (
                 holindex.holindex basename;
                 run_lexer := false)

Modified: HOL/src/TeX/mungeTools.sml
===================================================================
--- HOL/src/TeX/mungeTools.sml	2011-01-28 00:57:08 UTC (rev 8897)
+++ HOL/src/TeX/mungeTools.sml	2011-01-28 00:57:41 UTC (rev 8898)
@@ -11,6 +11,7 @@
              | AllTT | ShowTypes
              | Conj of int
              | Rule | StackedRule
+             | NoDollarParens
 
 val numErrors = ref 0
 type posn = int * int
@@ -42,6 +43,7 @@
   | "showtypes" => SOME ShowTypes
   | "rule" => SOME Rule
   | "stackedrule" => SOME StackedRule
+  | "nodollarparens" => SOME NoDollarParens
   | _ => let
     in
       if String.isPrefix ">>" s then let
@@ -278,15 +280,17 @@
       addz "}"
     end
 
-    fun stdtermprint t = let
-      val baseprint = raw_pp_term_as_tex overrides pps
-      val printer = if OptSet.has ShowTypes opts then
-                      trace ("types", 1) baseprint
-                    else trace ("types", 0) baseprint
-    in
-      printer t
-    end
+    fun optprintermod f pps =
+        f pps |> (if OptSet.has ShowTypes opts then
+                    trace ("types", 1)
+                  else trace ("types", 0))
+              |> (if OptSet.has NoDollarParens opts then
+                    trace ("EmitTeX: dollar parens", 0)
+                  else
+                    trace ("EmitTeX: dollar parens", 1))
 
+    fun stdtermprint pps t = optprintermod (raw_pp_term_as_tex overrides) pps t
+
     val () = if not alltt andalso not rulep then add_string pps "\\HOLinline{"
              else ()
     val parse_start = " (*#loc "^ Int.toString argline ^ " " ^
@@ -316,33 +320,24 @@
                               (fn pps => (add_newline pps; add_newline pps))
                             else add_newline
               val lines = thm |> CONJUNCTS |> map (concl o SPEC_ALL)
-              val printfn = let
-                val base = raw_pp_term_as_tex overrides
-              in
-                if OptSet.has ShowTypes opts then
-                  (fn pps => trace ("types", 1) (base pps))
-                else (fn pps => trace ("types", 0) (base pps))
-              end
             in
               begin_block pps CONSISTENT 0;
               block_list pps
                          (fn pps => begin_block pps INCONSISTENT 0)
-                         printfn
+                         stdtermprint
                          newline
                          end_block
                          lines;
               end_block pps
             end
-          else if rulep then rule_print stdtermprint (concl thm)
+          else if rulep then rule_print (stdtermprint pps) (concl thm)
           else let
-              val base = raw_pp_theorem_as_tex overrides pps
+              val base = raw_pp_theorem_as_tex overrides
+              val printer = optprintermod base pps
               val printer =
                   if OptSet.has NoTurnstile opts then
-                    trace ("EmitTeX: print thm turnstiles", 0) base
-                  else base
-              val printer =
-                  if OptSet.has ShowTypes opts then trace ("types", 1) printer
-                  else trace ("types", 0) printer
+                    trace ("EmitTeX: print thm turnstiles", 0) printer
+                  else printer
             in
               printer thm
             end
@@ -369,7 +364,8 @@
                       end
                    else ()
         in
-          if rulep then rule_print stdtermprint term else stdtermprint term
+          if rulep then rule_print (stdtermprint pps) term
+          else stdtermprint pps term
         end
       | Type => let
           val typ = if OptSet.has TypeOf opts


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 8917
          http://hol.svn.sourceforge.net/hol/?rev=8917&view=rev
Author:   michaeln
Date:     2011-02-13 05:05:36 +0000 (Sun, 13 Feb 2011)

Log Message:
-----------
Add new --nomergeanalysis option to mungers (documented in Description).

Modified Paths:
--------------
    HOL/Manual/Description/misc.tex
    HOL/src/TeX/mkmunger.sml
    HOL/src/TeX/mungeTools.sml

Modified: HOL/Manual/Description/misc.tex
===================================================================
--- HOL/Manual/Description/misc.tex	2011-02-11 05:00:47 UTC (rev 8916)
+++ HOL/Manual/Description/misc.tex	2011-02-13 05:05:36 UTC (rev 8917)
@@ -1104,10 +1104,15 @@
 \texttt{width=} option to any of the commands within a \LaTeX{}
 document.
 
+\paragraph{Preventing Merge Analysis}
+By default, the HOL pretty-printer is paranoid about token-merging, and will insert spaces between the tokens it emits to try to ensure that what is output can be read in again without error.
+%
+This behaviour can be frustrating when getting one's \LaTeX{} to look ``just so'', so it can be turned off with the \texttt{--nomergeanalysis} option to the munger.
+%
+(In interactive HOL, the token-merging analysis is controlled by a trace variable called \texttt{"pp\_avoids\_symbol\_merges"}.)
 
-\smallskip \noindent
-The \texttt{-w} and overrides file options can be given in either
-order.
+\smallskip \noindent The \texttt{-w}, \texttt{--nomergeanalysis} and
+overrides file options can be given in any order.
 
 \subsection{Holindex}
 

Modified: HOL/src/TeX/mkmunger.sml
===================================================================
--- HOL/src/TeX/mkmunger.sml	2011-02-11 05:00:47 UTC (rev 8916)
+++ HOL/src/TeX/mkmunger.sml	2011-02-13 05:05:36 UTC (rev 8917)
@@ -21,25 +21,24 @@
   fun setwidth i = mungeLex.UserDeclarations.width := i
   fun setoverrides s = mungeTools.user_overrides := mungeTools.read_overrides s
   val run_lexer = ref true
-  val _ = case CommandLine.arguments() of
-            [] => ()
-          | ["-index", basename] => (
-                holindex.holindex basename;
-                run_lexer := false)
-          | [s] => let
+  fun proc_args args =
+      case args of
+        [] => ()
+      | ["-index"] => mungeTools.usage()
+      | ["-index", basename] => (holindex.holindex basename; run_lexer := false)
+      | s :: rest => let
+        in
+          case parseWidth s of
+            SOME i => (setwidth i ; proc_args rest)
+          | NONE => let
             in
-              case parseWidth s of
-                NONE => setoverrides s
-              | SOME i => setwidth i
+              case s of
+                "--nomergeanalysis" => (set_trace "pp_avoids_symbol_merges" 0;
+                                        proc_args rest)
+              | _ => (setoverrides s ; proc_args rest)
             end
-          | [s1,s2] => let
-            in
-              case (parseWidth s1, parseWidth s2) of
-                (NONE, SOME i) => (setoverrides s1; setwidth i)
-              | (SOME i, NONE) => (setoverrides s2; setwidth i)
-              | _ => mungeTools.usage()
-            end
-          | _ => mungeTools.usage()
+        end
+  val _ = proc_args (CommandLine.arguments())
 in
   if (!run_lexer) then lexer() else ()
 end

Modified: HOL/src/TeX/mungeTools.sml
===================================================================
--- HOL/src/TeX/mungeTools.sml	2011-02-11 05:00:47 UTC (rev 8916)
+++ HOL/src/TeX/mungeTools.sml	2011-02-13 05:05:36 UTC (rev 8917)
@@ -25,8 +25,11 @@
 fun die s = (TextIO.output(TextIO.stdErr, s ^ "\n");
              TextIO.flushOut TextIO.stdErr;
              OS.Process.exit OS.Process.failure)
-fun usage() = die ("Usage:\n  "^CommandLine.name()^" [-w<linewidth>] [overridesfile] or\n"^
-                                CommandLine.name()^" -index filename")
+fun usage() =
+    die ("Usage:\n  "^
+         CommandLine.name()^" [-w<linewidth>] [--nomergeanalysis] " ^
+         "[overridesfile] or\n"^
+         CommandLine.name()^" -index filename")
 
 fun stringOpt pos s =
   case s of


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 8924
          http://hol.svn.sourceforge.net/hol/?rev=8924&view=rev
Author:   michaeln
Date:     2011-02-15 05:19:39 +0000 (Tue, 15 Feb 2011)

Log Message:
-----------
EmitTeX: new merge and nomerge options to \HOLtm and \HOLthm.

These allow per-entity control of whether or not token-merging analysis is
done.  For example, with it globally off (using --nomergeanalysis), theorems
involving LEAST will print with the bound variable squished up against the
LEAST:  ... (LEASTn. P n).

Putting merge back on for this one theorem will get the nice spacing
back again.

Modified Paths:
--------------
    HOL/Manual/Description/misc.tex
    HOL/src/TeX/mungeTools.sml

Modified: HOL/Manual/Description/misc.tex
===================================================================
--- HOL/Manual/Description/misc.tex	2011-02-15 05:19:00 UTC (rev 8923)
+++ HOL/Manual/Description/misc.tex	2011-02-15 05:19:39 UTC (rev 8924)
@@ -893,6 +893,18 @@
 %
 In this way, large complicated terms that are not themselves theorems (or even of boolean type), can be stored in \HOL{} theories, and then printed in \LaTeX{} documents.
 
+\item[\texttt{merge}, \texttt{nomerge}] (For use with \holtm{} and \holthm.)
+By default, the HOL pretty-printer is paranoid about token-merging, and will insert spaces between the tokens it emits to try to ensure that what is output can be read in again without error.
+%
+This behaviour can be frustrating when getting one's \LaTeX{} to look ``just so'', so it can be turned off with the \texttt{nomerge} option.
+
+Additionally, this behaviour can be turned off globally with the \texttt{--nomergeanalysis} option to the munger.
+%
+If this has been made the default, it may be useful to occasionally turn the merge analysis back on for a particular term or theorem; this is done with the \texttt{merge} option.
+%
+(In interactive HOL, the token-merging analysis is controlled by a trace variable called \texttt{"pp\_avoids\_symbol\_merges"}.)
+
+
 \item[\texttt{nodollarparens}] (For use with \holtm{} and \holthm.) Causes the default escaping of syntactic sugar to be suppressed.
 \index{ escape, in HOL logic parser@...{\$} (escape, in \HOL{} logic parser)}%
 \index{tokens!suppressing parsing behaviour of}
@@ -1104,12 +1116,7 @@
 \texttt{width=} option to any of the commands within a \LaTeX{}
 document.
 
-\paragraph{Preventing Merge Analysis}
-By default, the HOL pretty-printer is paranoid about token-merging, and will insert spaces between the tokens it emits to try to ensure that what is output can be read in again without error.
-%
-This behaviour can be frustrating when getting one's \LaTeX{} to look ``just so'', so it can be turned off with the \texttt{--nomergeanalysis} option to the munger.
-%
-(In interactive HOL, the token-merging analysis is controlled by a trace variable called \texttt{"pp\_avoids\_symbol\_merges"}.)
+\paragraph{Preventing Merge Analysis}  As mentioned above in the description of the \texttt{merge} and \texttt{nomerge} options to the \holtm{} and \holthm{} commands, the munger can be configured to not do token-merging avoidance by passing the \texttt{--nomergeanalysis} option to the munger.
 
 \smallskip \noindent The \texttt{-w}, \texttt{--nomergeanalysis} and
 overrides file options can be given in any order.

Modified: HOL/src/TeX/mungeTools.sml
===================================================================
--- HOL/src/TeX/mungeTools.sml	2011-02-15 05:19:00 UTC (rev 8923)
+++ HOL/src/TeX/mungeTools.sml	2011-02-15 05:19:39 UTC (rev 8924)
@@ -12,6 +12,7 @@
              | Conj of int
              | Rule | StackedRule
              | NoDollarParens
+             | Merge | NoMerge
 
 val numErrors = ref 0
 type posn = int * int
@@ -34,19 +35,21 @@
 fun stringOpt pos s =
   case s of
     "|-" => SOME Turnstile
+  | "alltt" => SOME AllTT
   | "case" => SOME Case
-  | "tt" => SOME TT
-  | "alltt" => SOME AllTT
   | "def" => SOME Def
-  | "spaceddef" => SOME SpacedDef
-  | "of" => SOME TypeOf
   | "K" => SOME TermThm
+  | "merge" => SOME Merge
+  | "nodollarparens" => SOME NoDollarParens
+  | "nomerge" => SOME NoMerge
   | "nosp" => SOME NoSpec
   | "nostile" => SOME NoTurnstile
+  | "of" => SOME TypeOf
+  | "rule" => SOME Rule
   | "showtypes" => SOME ShowTypes
-  | "rule" => SOME Rule
+  | "spaceddef" => SOME SpacedDef
   | "stackedrule" => SOME StackedRule
-  | "nodollarparens" => SOME NoDollarParens
+  | "tt" => SOME TT
   | _ => let
     in
       if String.isPrefix ">>" s then let
@@ -291,6 +294,12 @@
                     trace ("EmitTeX: dollar parens", 0)
                   else
                     trace ("EmitTeX: dollar parens", 1))
+              |> (if OptSet.has NoMerge opts then
+                    trace ("pp_avoids_symbol_merges", 0)
+                  else (fn f => f))
+              |> (if OptSet.has Merge opts then
+                    trace ("pp_avoids_symbol_merges", 1)
+                  else (fn f => f))
 
     fun stdtermprint pps t = optprintermod (raw_pp_term_as_tex overrides) pps t
 


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 9030
          http://hol.svn.sourceforge.net/hol/?rev=9030&view=rev
Author:   michaeln
Date:     2011-04-27 04:01:24 +0000 (Wed, 27 Apr 2011)

Log Message:
-----------
Theory of complex numbers.

E-mailed to me by Liming Li, based on a HOL Light development.
May need to revisit decision to use 'i' as the name for the constant (HOL
Light uses 'ii').  John also has complex as a whole new type; this
development just uses a real#real type abbreviation.  Of course, it's good
to explore the possibilities.

Modified Paths:
--------------
    HOL/tools/build-sequence

Added Paths:
-----------
    HOL/src/complex/
    HOL/src/complex/complexScript.sml

Added: HOL/src/complex/complexScript.sml
===================================================================
--- HOL/src/complex/complexScript.sml	                        (rev 0)
+++ HOL/src/complex/complexScript.sml	2011-04-27 04:01:24 UTC (rev 9030)
@@ -0,0 +1,1389 @@
+(* ==================================================================
+   TITLE: Developing the theory of complex number
+
+   DESCRIPTION : Definitions and properties of the complex data type
+      and arithmetic operations of complex numbers, and many
+      properties organized in terms of group, field and R-module.
+      Moreover, definitions and properties of complex conjugate,
+      modulus and argument principal value of complex, the operation
+      of nature numbers power of complex numbers, the polar form and
+      exponential form of complex numbers.
+
+   AUTHORS  : (Copyright) Yong Guan, Liming Li, Minhua Wu  and
+              Zhiping Shi
+              Beijing Engineering Research Center of High Reliable
+              Emmbedded System, Capital Normal University, China
+   DATE  : 2011.04.23
+   REFERENCES  : John Harrison, realScript.sml and complex.ml
+   ================================================================== *)
+
+open HolKernel boolLib Parse bossLib
+open arithmeticTheory numLib pairTheory realTheory realLib transcTheory
+open tautLib AC
+
+val _ = new_theory "complex";
+
+(* ------------------------------------------------------------------ *)
+(* Definition of complex number type.                                 *)
+(* ------------------------------------------------------------------ *)
+
+val _ = type_abbrev ("complex", ``: real # real``);
+
+(*--------------------------------------------------------------------*)
+(* Now prove 2 lemmas.                                                *)
+(*--------------------------------------------------------------------*)
+
+val COMPLEX_LEMMA1= store_thm("COMPLEX_LEMMA1",
+  ``!a:real b:real c:real d:real.
+     (a * c- b * d) pow 2 + (a * d + b * c) pow 2 =
+              (a pow 2 + b pow 2) * (c pow 2 + d pow 2)``,
+  REWRITE_TAC[POW_2] THEN REAL_ARITH_TAC);
+
+val COMPLEX_LEMMA2 = store_thm("COMPLEX_LEMMA2",
+  ``!x y : real. abs x <= sqrt (x pow 2 + y pow 2)``,
+  REPEAT GEN_TAC THEN `0 <= abs x` by PROVE_TAC[ABS_POS] THEN
+  `abs x = sqrt (abs x pow 2)` by PROVE_TAC[POW_2_SQRT] THEN
+  ONCE_ASM_REWRITE_TAC[] THEN REWRITE_TAC[REAL_POW2_ABS] THEN
+  `0 <= x pow 2 /\ 0 <= y pow 2` by PROVE_TAC[REAL_LE_POW2] THEN
+  ` x pow 2 <= x pow 2 + y pow 2` by PROVE_TAC[REAL_LE_ADDR] THEN
+  PROVE_TAC[SQRT_MONO_LE]);
+
+(*--------------------------------------------------------------------*)
+(* Now define real part and imaginary part of complex number.         *)
+(*--------------------------------------------------------------------*)
+
+val RE = new_definition("RE",``RE (z:complex) = FST z``);
+
+val IM = new_definition("IM",``IM (z:complex) = SND z``);
+
+val COMPLEX = store_thm("COMPLEX",
+  ``!z:complex. (RE z,IM z) = z``,
+  REWRITE_TAC[RE,IM]);
+
+val COMPLEX_RE_IM_EQ = store_thm("COMPLEX_RE_IM_EQ",
+  ``!z:complex w:complex. (z = w) = (RE z = RE w) /\ (IM z = IM w)``,
+  REWRITE_TAC[RE,IM, PAIR_FST_SND_EQ]);
+
+
+
+(*--------------------------------------------------------------------*)
+(* Now define the inclusion homomorphism: real->complex               *)
+(*                                      : num->complex                *)
+(*--------------------------------------------------------------------*)
+
+val complex_of_real = new_definition("complex_of_real",
+  ``complex_of_real (x:real) = (x,&0)``);
+
+val RE_COMPLEX_OF_REAL = store_thm("RE_COMPLEX_OF_REAL",
+  ``!x:real. RE (complex_of_real x) = x``,
+  REWRITE_TAC [complex_of_real,RE]);
+
+val IM_COMPLEX_OF_REAL = store_thm("IM_COMPLEX_OF_REAL",
+  ``!x:real. IM (complex_of_real x) = &0``,
+  REWRITE_TAC [complex_of_real, IM]);
+
+val complex_of_num = new_definition
+             ( "complex_of_num",
+ ``complex_of_num (n:num) = complex_of_real (real_of_num n)``);
+
+val _ = add_numeral_form(#"c", SOME "complex_of_num");
+
+val COMPLEX_0 = store_thm("COMPLEX_0",
+  ``0 = complex_of_real &0``,
+  REWRITE_TAC[complex_of_num]);
+
+val COMPLEX_1 = store_thm("COMPLEX_1",
+  ``1 = complex_of_real 1``,
+  REWRITE_TAC[complex_of_num]);
+
+val COMPLEX_10 = store_thm("COMPLEX_10",
+  ``~(1 = 0)``,
+  REWRITE_TAC[complex_of_num, complex_of_real, COMPLEX_RE_IM_EQ, RE, IM, REAL_10]);
+
+val COMPLEX_0_THM = store_thm("COMPLEX_0_THM",
+  ``!z:complex. (z = 0) = (RE z pow 2 + IM z pow 2 = &0)``,
+  REWRITE_TAC [complex_of_num, complex_of_real,RE, IM, PAIR_FST_SND_EQ, POW_2, REAL_SUMSQ]);
+
+(* ------------------------------------------------------------------ *)
+(* Imaginary unit                                                     *)
+(* ------------------------------------------------------------------ *)
+
+val i = new_definition ("i", ``i = (0r,1r)``);
+
+(* ------------------------------------------------------------------ *)
+(* Arithmetic operations.                                             *)
+(* ------------------------------------------------------------------ *)
+
+val complex_add = new_definition
+("complex_add",
+``complex_add (z:complex) (w:complex) = (RE z + RE w,IM z + IM w)``);
+
+val complex_neg = new_definition
+("complex_neg",
+    ``complex_neg (z:complex) = (-RE z, -IM z)``);
+
+val complex_mul = new_definition
+("complex_mul",
+    ``complex_mul (z:complex) (w:complex) =
+              (RE z * RE w - IM z * IM w, RE z * IM w + IM z * RE w)``);
+
+val complex_inv = new_definition
+ ("complex_inv",
+   ``complex_inv (z:complex) =
+         (RE z / ((RE z) pow 2 + (IM z) pow 2),
+                              -IM z / ((RE z) pow 2 + (IM z) pow 2))``);
+
+val _ = overload_on ("+",  Term`$complex_add`);
+val _ = overload_on ("~",  Term`$complex_neg`);
+val _ = overload_on ("*",  Term`$complex_mul`);
+val _ = overload_on ("inv",  Term`$complex_inv`);
+val _ = overload_on ("numeric_negate", ``$~ : complex->complex``);
+
+val complex_sub = new_definition
+("complex_sub",
+ ``complex_sub (z:complex) (w:complex) = z + ~w``);
+
+val complex_div = new_definition
+("complex_div",
+ ``complex_div (z:complex) (w:complex) = z * inv w``);
+
+val _ = overload_on ("-",  Term`$complex_sub`);
+val _ = overload_on ("/",  Term`$complex_div`);
+
+(*--------------------------------------------------------------------*)
+(* Prove lots of field theorems                                       *)
+(*--------------------------------------------------------------------*)
+
+val COMPLEX_ADD_COMM = store_thm("COMPLEX_ADD_COMM",
+  ``!z:complex w:complex. z + w = w + z``,
+  REWRITE_TAC [complex_add, RE, IM] THEN PROVE_TAC [REAL_ADD_COMM]);
+
+val COMPLEX_ADD_ASSOC = store_thm("COMPLEX_ADD_ASSOC",
+  ``!z:complex w:complex v:complex. z + (w + v) = z + w + v``,
+  REWRITE_TAC [complex_add, RE, IM] THEN PROVE_TAC [REAL_ADD_ASSOC]);
+
+val COMPLEX_ADD_RID = store_thm("COMPLEX_ADD_RID",
+  ``!z:complex. z + 0 = z``,
+  REWRITE_TAC [complex_of_num,complex_of_real, complex_add, REAL_ADD_RID, RE, IM]);
+
+val COMPLEX_ADD_LID = store_thm("COMPLEX_ADD_LID",
+  ``!z:complex. 0 + z = z``,
+  PROVE_TAC [COMPLEX_ADD_COMM, COMPLEX_ADD_RID]);
+
+val COMPLEX_ADD_RINV = store_thm("COMPLEX_ADD_RINV",
+  ``!z:complex. z + -z = 0``,
+  REWRITE_TAC [complex_of_num, complex_of_real, complex_add, complex_neg, REAL_ADD_RINV, RE, IM]);
+
+val COMPLEX_ADD_LINV = store_thm("COMPLEX_ADD_LINV",
+  ``!z:complex. -z + z = 0``,
+  PROVE_TAC [COMPLEX_ADD_COMM, COMPLEX_ADD_RINV]);
+
+val COMPLEX_MUL_COMM = store_thm("COMPLEX_MUL_COMM",
+  ``!z:complex w:complex. z * w = w * z ``,
+  REPEAT GEN_TAC THEN REWRITE_TAC [complex_mul,RE,IM] THEN PROVE_TAC[REAL_MUL_COMM,REAL_ADD_COMM]);
+
+val COMPLEX_MUL_ASSOC = store_thm("COMPLEX_MUL_ASSOC",
+  ``!z:complex w:complex v:complex. z * (w * v) = z * w * v``,
+  REPEAT GEN_TAC THEN REWRITE_TAC [complex_mul, RE, IM, REAL_SUB_LDISTRIB, REAL_ADD_LDISTRIB, REAL_SUB_RDISTRIB, REAL_ADD_RDISTRIB, REAL_MUL_ASSOC] THEN REWRITE_TAC [real_sub, REAL_NEG_ADD] THEN RW_TAC std_ss[] THEN CONV_TAC(AC_CONV(REAL_ADD_ASSOC,REAL_ADD_SYM)));
+
+val COMPLEX_MUL_RID = store_thm("COMPLEX_MUL_RID",
+  ``!z:complex. z * 1 = z``,
+  REPEAT GEN_TAC THEN REWRITE_TAC [complex_of_num, complex_of_real, complex_mul, REAL_MUL_RZERO, REAL_MUL_RID, REAL_SUB_RZERO, REAL_ADD_LID,RE,IM]);
+
+val COMPLEX_MUL_LID = store_thm("COMPLEX_MUL_LID",
+  ``!z:complex. 1 * z = z``,
+  PROVE_TAC[COMPLEX_MUL_COMM, COMPLEX_MUL_RID]);
+
+val COMPLEX_MUL_RINV = store_thm("COMPLEX_MUL_RINV",
+  ``!z:complex. ~(z = 0) ==> (z * inv z = 1)``,
+  REWRITE_TAC [complex_of_num, complex_of_real, COMPLEX_0_THM, complex_inv, complex_mul, RE, IM, POW_2] THEN
+  RW_TAC std_ss[] THEN
+  `1 = (FST z * FST z + SND z * SND z) / (FST z * FST z + SND z * SND z)` by RW_TAC real_ss[REAL_DIV_REFL]
+  THEN ASM_REWRITE_TAC[] THEN REWRITE_TAC [real_div] THEN REAL_ARITH_TAC);
+
+val COMPLEX_MUL_LINV = store_thm("COMPLEX_MUL_LINV",
+  ``!z:complex. ~(z = 0) ==> (inv z * z = 1)``,
+  PROVE_TAC[COMPLEX_MUL_COMM,COMPLEX_MUL_RINV]);
+
+val COMPLEX_ADD_LDISTRIB = store_thm("COMPLEX_ADD_LDISTRIB",
+  ``!z:complex w:complex v:complex. z * (w + v) = z * w + z * v``,
+  REWRITE_TAC [complex_mul,complex_add,RE,IM,REAL_ADD_LDISTRIB] THEN
+  REWRITE_TAC [real_sub, REAL_NEG_ADD] THEN RW_TAC std_ss[] THEN
+  CONV_TAC(AC_CONV(REAL_ADD_ASSOC,REAL_ADD_SYM)));
+
+val COMPLEX_ADD_RDISTRIB = store_thm("COMPLEX_ADD_RDISTRIB",
+  ``!z:complex w:complex v:complex. (z + w) * v = z * v + w * v``,
+  PROVE_TAC [COMPLEX_MUL_COMM,COMPLEX_ADD_LDISTRIB]);
+
+val COMPLEX_EQ_LADD = store_thm("COMPLEX_EQ_LADD",
+  ``!z:complex w:complex v:complex. (z + w = z + v) = (w = v)``,
+  REWRITE_TAC[complex_add, PAIR_EQ, REAL_EQ_LADD, GSYM COMPLEX_RE_IM_EQ]);
+
+val COMPLEX_EQ_RADD = store_thm("COMPLEX_EQ_RADD",
+  ``!z:complex w:complex v:complex. (z + v = w + v) = (z = w)``,
+  ONCE_REWRITE_TAC [COMPLEX_ADD_COMM] THEN REWRITE_TAC [COMPLEX_EQ_LADD]);
+
+val COMPLEX_ADD_RID_UNIQ = store_thm("COMPLEX_ADD_RID_UNIQ",
+  ``!z:complex w:complex. (z + w = z) = (w = 0)``,
+  REWRITE_TAC [complex_of_num, complex_of_real, complex_add, COMPLEX_RE_IM_EQ, RE, IM, REAL_ADD_RID_UNIQ]);
+
+val COMPLEX_ADD_LID_UNIQ = store_thm("COMPLEX_ADD_LID_UNIQ",
+  ``!z:complex w:complex. (z + w = w) = (z = 0)``,
+  ONCE_REWRITE_TAC [COMPLEX_ADD_COMM] THEN
+  REWRITE_TAC [COMPLEX_ADD_RID_UNIQ]);
+
+val COMPLEX_NEGNEG = store_thm("COMPLEX_NEGNEG",
+  ``!z:complex. --z = z``,
+  REWRITE_TAC [complex_neg, RE, IM, REAL_NEGNEG]);
+
+val COMPLEX_NEG_EQ = store_thm("COMPLEX_NEG_Q",
+  ``!z:complex w:complex. (-z = w) = (z = -w)``,
+  REWRITE_TAC [complex_neg, COMPLEX_RE_IM_EQ, RE, IM, REAL_NEG_EQ]);
+
+val COMPLEX_EQ_NEG = store_thm("COMPLEX_EQ_NEG",
+  ``!z:complex w:complex. (-z = -w) = (z = w)``,
+ REWRITE_TAC [COMPLEX_NEG_EQ, COMPLEX_NEGNEG]);
+
+val COMPLEX_RNEG_UNIQ = store_thm("COMPLEX_RNEG_UNIQ",
+  ``!z:complex w:complex. (z + w = 0) = (w = -z) ``,
+  REWRITE_TAC [complex_of_num, complex_of_real, GSYM COMPLEX_ADD_RINV] THEN PROVE_TAC [COMPLEX_ADD_COMM, COMPLEX_EQ_LADD]);
+
+val COMPLEX_LNEG_UNIQ = store_thm("COMPLEX_LNEG_UNIQ",
+  ``!z:complex w:complex. (z + w = 0) = (z = -w) ``,
+  PROVE_TAC[COMPLEX_RNEG_UNIQ,COMPLEX_NEG_EQ]);
+
+val COMPLEX_NEG_ADD = store_thm("COMPLEX_NEG_ADD",
+  ``!z:complex w:complex. -(z + w) = -z + -w ``,
+  REWRITE_TAC[complex_neg,complex_add ,RE,IM, REAL_NEG_ADD]);
+
+val COMPLEX_MUL_RZERO = store_thm("COMPLEX_MUL_RZERO",
+  ``!z:complex. z * 0 = 0``,
+  REWRITE_TAC [complex_of_num, complex_of_real, complex_mul, REAL_MUL_RZERO, REAL_ADD_RID, REAL_SUB_RZERO, RE,IM]);
+
+val COMPLEX_MUL_LZERO = store_thm("COMPLEX_MUL_LZERO",
+  ``!z:complex. 0 * z = 0``,
+  PROVE_TAC[COMPLEX_MUL_COMM, COMPLEX_MUL_RZERO]);
+
+val COMPLEX_NEG_LMUL = store_thm("COMPLEX_NEG_LMUL",
+  ``!z:complex w:complex. -(z * w) = -z * w ``,
+  REWRITE_TAC [complex_neg, complex_mul, RE,IM, real_sub, REAL_NEG_ADD, REAL_NEG_LMUL]);
+
+val COMPLEX_NEG_RMUL = store_thm("COMPLEX_NEG_RMUL",
+  ``!z:complex w:complex. -(z * w) = z * -w ``,
+  PROVE_TAC [COMPLEX_NEG_LMUL, COMPLEX_MUL_COMM]);
+
+val COMPLEX_NEG_MUL2 = store_thm("COMPLEX_NEG_MUL2",
+  ``!z:complex w:complex. -z * -w = z * w ``,
+  REWRITE_TAC [GSYM COMPLEX_NEG_LMUL, GSYM COMPLEX_NEG_RMUL, COMPLEX_NEGNEG]);
+
+val COMPLEX_ENTIRE = store_thm("COMPLEX_ENTIRE",
+  ``!z:complex w:complex.
+            (z * w = 0) = (z = 0) \/ (w = 0)``,
+  REWRITE_TAC[complex_of_num, complex_of_real, COMPLEX_0_THM, complex_mul, RE,IM,COMPLEX_LEMMA1,REAL_ENTIRE]);
+
+val COMPLEX_NEG_0 = store_thm("COMPLEX_NEG_0",
+  ``-0 = 0``,
+  REWRITE_TAC [complex_of_num, complex_of_real, complex_neg, RE, IM, REAL_NEG_0]);
+
+val COMPLEX_NEG_EQ0 = store_thm("COMPLEX_NEG_0",
+  ``!z:complex. (-z = 0) = (z = 0)``,
+  REWRITE_TAC[COMPLEX_NEG_EQ,COMPLEX_NEG_0]);
+
+val COMPLEX_SUB_REFL = store_thm("COMPLEX_SUB_REFL",
+  ``!z:complex. z - z = 0``,
+  REPEAT GEN_TAC THEN REWRITE_TAC [complex_sub, COMPLEX_ADD_RINV]);
+
+val COMPLEX_SUB_RZERO = store_thm("COMPLEX_SUB_RZERO",
+  ``!z:complex. z - 0 = z``,
+  REWRITE_TAC [complex_sub, COMPLEX_NEG_0, COMPLEX_ADD_RID]);
+
+val COMPLEX_SUB_LZERO = store_thm("COMPLEX_SUB_LZERO",
+  ``!z:complex. 0 - z = -z``,
+  REWRITE_TAC [complex_sub, COMPLEX_ADD_LID]);
+
+val COMPLEX_SUB_LNEG = store_thm("COMPLEX_SUB_G",
+  ``!z:complex w:complex. -z - w = -(z + w)``,
+  REPEAT GEN_TAC THEN REWRITE_TAC [complex_sub, COMPLEX_NEG_ADD]);
+
+val COMPLEX_SUB_NEG2 = store_thm("COMPLEX_SUB_NEG2",
+  ``!z:complex w:complex. -z - -w = w - z``,
+  REWRITE_TAC[complex_sub, COMPLEX_NEGNEG] THEN PROVE_TAC [COMPLEX_ADD_COMM]);
+
+val COMPLEX_NEG_SUB = store_thm("COMPLEX_NEG_SUB",
+  ``!z:complex w:complex. -(z - w) = w - z ``,
+  REWRITE_TAC[complex_sub, COMPLEX_NEG_ADD, COMPLEX_NEGNEG] THEN
+  PROVE_TAC [COMPLEX_ADD_COMM]);
+
+val COMPLEX_SUB_RNEG = store_thm("COMPLEX_SUB_RNEG",
+  ``!z:complex w:complex. z - -w = z + w``,
+  REPEAT GEN_TAC THEN REWRITE_TAC [complex_sub, COMPLEX_NEGNEG]);
+
+val COMPLEX_SUB_ADD = store_thm ("COMPLEX_SUB_ADD",
+  (``!z:complex w:complex. (z - w) + w = z``),
+  REWRITE_TAC [complex_sub, GSYM COMPLEX_ADD_ASSOC,    COMPLEX_ADD_LINV, COMPLEX_ADD_RID]);
+
+val COMPLEX_SUB_ADD2 = store_thm("COMPLEX_SUB_ADD2",
+  (``!z:complex w:complex. w + (z - w) = z``),
+  REPEAT GEN_TAC THEN ONCE_REWRITE_TAC[COMPLEX_ADD_COMM] THEN
+  MATCH_ACCEPT_TAC COMPLEX_SUB_ADD);
+
+val COMPLEX_ADD_SUB = store_thm ("COMPLEX_ADD_SUB",
+  (``!z:complex w:complex. (z + w) - z = w``),
+  REPEAT GEN_TAC THEN ONCE_REWRITE_TAC[COMPLEX_ADD_COMM] THEN
+  REWRITE_TAC[complex_sub, GSYM COMPLEX_ADD_ASSOC, COMPLEX_ADD_RINV, COMPLEX_ADD_RID]);
+
+val COMPLEX_SUB_SUB = store_thm ("COMPLEX_SUB_SUB",
+  ``!z:complex w:complex. (z - w) - z = -w ``,
+  REPEAT GEN_TAC THEN REWRITE_TAC[complex_sub] THEN
+  REWRITE_TAC[GSYM COMPLEX_ADD_ASSOC] THEN
+  ONCE_REWRITE_TAC[COMPLEX_ADD_COMM] THEN
+  REWRITE_TAC[GSYM COMPLEX_ADD_ASSOC] THEN
+  REWRITE_TAC[COMPLEX_ADD_LINV, COMPLEX_ADD_RID]);
+
+val COMPLEX_SUB_SUB2 = store_thm("COMPLEX_SUB_SUB2",
+  ``!z:complex w:complex. z - (z - w) = w``,
+  REPEAT GEN_TAC THEN ONCE_REWRITE_TAC[GSYM COMPLEX_NEGNEG] THEN
+  AP_TERM_TAC THEN REWRITE_TAC[COMPLEX_NEG_SUB, COMPLEX_SUB_SUB]);
+
+val COMPLEX_ADD_SUB2 = store_thm("COMPLEX_ADD_SUB2",
+   ``!z:complex w:complex. z - (z + w) = -w``,
+  REPEAT GEN_TAC THEN ONCE_REWRITE_TAC[GSYM COMPLEX_NEG_SUB] THEN
+  AP_TERM_TAC THEN REWRITE_TAC[COMPLEX_ADD_SUB]);
+
+val COMPLEX_ADD2_SUB2 = store_thm("COMPLEX_ADD2_SUB2",
+  ``!z:complex w:complex u:complex v:complex.
+(z + w) - (u + v) = (z - u) + (w - v)``,
+  REPEAT GEN_TAC THEN REWRITE_TAC[complex_sub, COMPLEX_NEG_ADD] THEN
+  CONV_TAC(AC_CONV(COMPLEX_ADD_ASSOC,COMPLEX_ADD_COMM)));
+
+val COMPLEX_SUB_TRIANGLE = store_thm("COMPLEX_SUB_TRIANGLE",
+  ``!z:complex w:complex v:complex. (z - w) + (w - v) = z - v``,
+  REPEAT GEN_TAC THEN REWRITE_TAC[complex_sub] THEN
+  ONCE_REWRITE_TAC[AC(COMPLEX_ADD_ASSOC,COMPLEX_ADD_COMM)
+    ``(a + b) + (c + d) = (b + c) + (a + d)``] THEN
+  REWRITE_TAC[COMPLEX_ADD_LINV, COMPLEX_ADD_LID]);
+
+val COMPLEX_SUB_0 = store_thm("COMPLEX_SUB_0",
+  ``!z:complex w:complex. (z - w = 0) = (z = w)``,
+  REWRITE_TAC [complex_sub, COMPLEX_LNEG_UNIQ , COMPLEX_NEGNEG]);
+
+val COMPLEX_EQ_SUB_LADD = store_thm("COMPLEX_EQ_SUB_LADD",
+  ``!z:complex w:complex v:complex. (z = w - v) = (z + v = w)``,
+  REPEAT GEN_TAC THEN
+ (SUBST1_TAC o SYM o C SPECL COMPLEX_EQ_RADD) [``z:complex``, ``w - v``, ``v:complex``] THEN
+  REWRITE_TAC[COMPLEX_SUB_ADD]);
+
+val COMPLEX_EQ_SUB_RADD = store_thm("COMPLEX_EQ_SUB_RADD",
+  ``!z:complex w:complex v:complex. (z - w = v) = (z = v + w)``,
+  REPEAT GEN_TAC THEN
+  CONV_TAC(SUB_CONV(ONCE_DEPTH_CONV SYM_CONV)) THEN
+  MATCH_ACCEPT_TAC COMPLEX_EQ_SUB_LADD);
+
+val COMPLEX_MUL_RNEG = store_thm("COMPLEX_MUL_RNEG",
+  ``! z:complex w:complex. z * -w = -(z * w)``,
+  REWRITE_TAC[COMPLEX_NEG_RMUL]);
+
+val COMPLEX_MUL_LNEG = store_thm("COMPLEX_MUL_LNEG",
+  ``! z:complex w:complex. -z * w = -(z * w)``,
+  REWRITE_TAC[COMPLEX_NEG_LMUL]);
+
+val COMPLEX_SUB_LDISTRIB = store_thm("COMPLEX_ADD_LDISTRIB",
+  ``!z:complex w:complex v:complex. z * (w - v) = z * w - z * v``,
+  REWRITE_TAC [complex_sub, COMPLEX_ADD_LDISTRIB, GSYM COMPLEX_NEG_RMUL]);
+
+val COMPLEX_SUB_RDISTRIB = store_thm("COMPLEX_ADD_RDISTRIB",
+  ``!z:complex w:complex v:complex. (z - w) * v = z * v - w * v``,
+  PROVE_TAC [COMPLEX_MUL_COMM,COMPLEX_SUB_LDISTRIB]);
+
+val COMPLEX_DIFFSQ = store_thm("COMPLEX_DIFFSQ",
+  ``!z:complex w:complex. (z + w) * (z - w) = z * z - w * w ``,
+  REWRITE_TAC[COMPLEX_ADD_RDISTRIB, COMPLEX_SUB_LDISTRIB, complex_sub, GSYM COMPLEX_ADD_ASSOC, COMPLEX_EQ_LADD] THEN
+  REWRITE_TAC [COMPLEX_ADD_ASSOC, COMPLEX_ADD_LID_UNIQ]  THEN
+  PROVE_TAC [COMPLEX_ADD_COMM, COMPLEX_MUL_COMM, COMPLEX_ADD_RINV]);
+
+val COMPLEX_EQ_LMUL = store_thm("COMPLEX_EQ_LMUL",
+  ``!z:complex w:complex v:complex.
+           (z * w = z * v) = (z = 0) \/ (w = v)``,
+  ONCE_REWRITE_TAC [GSYM COMPLEX_SUB_0] THEN
+  REWRITE_TAC [GSYM COMPLEX_SUB_LDISTRIB, COMPLEX_ENTIRE, COMPLEX_SUB_RZERO]);
+
+val COMPLEX_EQ_RMUL = store_thm("COMPLEX_EQ_LMUL",
+  ``!z:complex w:complex v:complex.
+               (z * v = w * v) = (v = 0) \/ (z = w)``,
+  PROVE_TAC[COMPLEX_MUL_COMM, COMPLEX_EQ_LMUL]);
+
+val COMPLEX_EQ_LMUL2 = store_thm("COMPLEX_EQ_LMUL2",
+  ``!z:complex w:complex v:complex.
+          ~(z = 0) ==> ((w = v) = (z * w = z * v))``,
+  REPEAT GEN_TAC THEN DISCH_TAC THEN
+  MP_TAC(SPECL [``z:complex``, ``w:complex``, ``v:complex``] COMPLEX_EQ_LMUL) THEN
+  ASM_REWRITE_TAC[] THEN DISCH_THEN SUBST_ALL_TAC THEN REFL_TAC);
+
+val COMPLEX_EQ_RMUL_IMP = store_thm("COMPLEX_EQ_RMUL_IMP",
+  ``!z:complex w:complex v:complex.
+              ~(z = 0) /\ (w * z = v * z)==> (w = v)``,
+  REPEAT GEN_TAC THEN DISCH_THEN(CONJUNCTS_THEN2 ASSUME_TAC MP_TAC) THEN
+  ASM_REWRITE_TAC[COMPLEX_EQ_RMUL]);
+
+val COMPLEX_EQ_LMUL_IMP = store_thm("COMPLEX_EQ_LMUL_IMP",
+   ``!z:complex w:complex v:complex.
+           ~(z = 0) /\ (z * w = z * v)==> (w = v)``,
+  ONCE_REWRITE_TAC[COMPLEX_MUL_COMM] THEN
+  MATCH_ACCEPT_TAC COMPLEX_EQ_RMUL_IMP);
+
+val COMPLEX_NEG_INV = store_thm("COMPLEX_NEG_INV",
+  ``!z: complex. ~(z = 0) ==> (inv (-z) = -(inv z))``,
+  REWRITE_TAC [COMPLEX_0_THM,complex_inv,complex_neg,RE,IM,POW_2] THEN
+  RW_TAC real_ss[real_div]);
+
+val COMPLEX_INV_MUL = store_thm("COMPLEX_INV_MUL",
+  ``!z:complex w:complex.
+        (z <> 0 /\ w <> 0) ==> (inv (z * w) = inv z * inv w)``,
+  REWRITE_TAC [complex_inv,COMPLEX_0_THM, complex_mul, RE,IM] THEN
+  RW_TAC real_ss[real_div,COMPLEX_LEMMA1,REAL_INV_MUL] THEN REAL_ARITH_TAC);
+
+val COMPLEX_INVINV = store_thm("COMPLEX_INVINV",
+  ``!z: complex. (z <> 0) ==> (inv (inv z) = z)``,
+  REPEAT STRIP_TAC THEN
+  FIRST_ASSUM(MP_TAC o MATCH_MP COMPLEX_MUL_RINV) THEN
+  ASM_CASES_TAC ``inv z = 0`` THENL[
+  ASM_REWRITE_TAC[COMPLEX_MUL_RZERO, GSYM COMPLEX_10],
+  MP_TAC(SPECL [``inv(inv z)``, ``z:complex``, ``inv z``] COMPLEX_EQ_RMUL)
+  THEN ASM_REWRITE_TAC[] THEN DISCH_THEN(SUBST1_TAC o SYM) THEN
+  DISCH_THEN SUBST1_TAC THEN MATCH_MP_TAC COMPLEX_MUL_LINV THEN
+  FIRST_ASSUM ACCEPT_TAC]);
+
+val COMPLEX_LINV_UNIQ = store_thm("COMPLEX_LINV_UNIQ",
+  ``!z:complex w:complex. (z * w = 1) ==> (z = inv w)``,
+  REPEAT GEN_TAC THEN ASM_CASES_TAC (``z = 0``) THENL
+  [ASM_REWRITE_TAC [COMPLEX_MUL_LZERO, GSYM COMPLEX_10],
+  DISCH_THEN(MP_TAC o AP_TERM (``$* (inv z:complex) ``)) THEN
+  REWRITE_TAC [COMPLEX_MUL_ASSOC] THEN
+  FIRST_ASSUM (fn th=> REWRITE_TAC [MATCH_MP COMPLEX_MUL_LINV th]) THEN
+  REWRITE_TAC [COMPLEX_MUL_LID, COMPLEX_MUL_RID] THEN
+  DISCH_THEN SUBST1_TAC THEN CONV_TAC SYM_CONV THEN
+  POP_ASSUM MP_TAC THEN MATCH_ACCEPT_TAC COMPLEX_INVINV]);
+
+val COMPLEX_RINV_UNIQ = store_thm("COMPLEX_RINV_UNIQ",
+  ``!z:complex w:complex. (z * w = 1) ==> (w = inv z)``,
+  REPEAT GEN_TAC THEN ONCE_REWRITE_TAC[COMPLEX_MUL_COMM] THEN
+  MATCH_ACCEPT_TAC COMPLEX_LINV_UNIQ);
+
+val COMPLEX_INV_0 = store_thm("COMPLEX_INV_0",
+  ``inv 0 = 0``,
+   RW_TAC real_ss [complex_of_num, complex_of_real, complex_inv, RE, IM, POW_2, real_div, REAL_INV_0]);
+
+val COMPLEX_INV1 = store_thm("COMPLEX_INV1",
+  ``inv 1 = 1``,
+  RW_TAC real_ss [complex_of_num, complex_of_real, complex_inv, RE, IM, POW_2, real_div, REAL_INV1]);
+
+val COMPLEX_INV_INV = store_thm("COMPLEX_INV_INV",
+  ``!z: complex. inv (inv z) = z ``,
+  GEN_TAC THEN ASM_CASES_TAC (``z = 0``) THENL
+  [ASM_REWRITE_TAC [COMPLEX_INV_0],
+   MATCH_MP_TAC COMPLEX_INVINV THEN ASM_REWRITE_TAC[]]);
+
+val COMPLEX_INV_NEG = store_thm("COMPLEX_INV_NEG",
+  ``!z: complex. (inv (-z) = -(inv z))``,
+  GEN_TAC THEN ASM_CASES_TAC (``z = 0``) THEN
+  ASM_REWRITE_TAC [COMPLEX_INV_0, COMPLEX_NEG_0] THEN
+  MATCH_MP_TAC COMPLEX_NEG_INV THEN ASM_REWRITE_TAC[]);
+
+val COMPLEX_INV_EQ_0 = store_thm ("COMPLEX_INV_EQ_0",
+ ``!z: complex. (inv z = 0) = (z = 0)``,
+  GEN_TAC THEN EQ_TAC THEN DISCH_TAC THEN
+  ASM_REWRITE_TAC[COMPLEX_INV_0] THEN
+  ONCE_REWRITE_TAC[GSYM COMPLEX_INV_INV] THEN
+  ASM_REWRITE_TAC[COMPLEX_INV_0]);
+
+val COMPLEX_INV_NZ = store_thm ("COMPLEX_INV_NZ",
+  ``!z:complex. ~(z = 0) ==> ~(inv z = 0)``,
+  REWRITE_TAC[COMPLEX_INV_EQ_0]);
+
+val COMPLEX_INV_INJ = store_thm("COMPLEX_INV_INJ",
+  ``!z: complex w: complex. (inv z = inv w) = (z = w)``,
+  PROVE_TAC[COMPLEX_INV_INV] );
+
+val COMPLEX_NEG_LDIV= store_thm("COMPLEX_NEG_LDIV",
+  ``!z w : complex. -(z / w) = -z / w``,
+  REWRITE_TAC[complex_div, COMPLEX_NEG_LMUL]);
+
+val COMPLEX_NEG_RDIV= store_thm("COMPLEX_NEG_RDIV",
+  ``!z w : complex. -(z / w) = z / -w``,
+  REWRITE_TAC[complex_div, COMPLEX_INV_NEG, COMPLEX_NEG_RMUL]);
+
+val COMPLEX_NEG_DIV2= store_thm("COMPLEX_NEG_DIV2",
+  ``!z w : complex. -z / -w = z / w ``,
+  REWRITE_TAC[complex_div, COMPLEX_INV_NEG, COMPLEX_NEG_MUL2]);
+
+val COMPLEX_INV_1OVER= store_thm("COMPLEX_INV_1OVER",
+  ``!z: complex. inv z = 1 / z ``,
+  REWRITE_TAC[complex_div, COMPLEX_MUL_LID]);
+
+val COMPLEX_DIV1= store_thm("COMPLEX_DIV1",
+  ``!z: complex. z / 1 = z ``,
+  REWRITE_TAC[complex_div, COMPLEX_INV1,COMPLEX_MUL_RID]);
+
+val COMPLEX_DIV_ADD = store_thm("COMPLEX_DIV_ADD",
+  ``!z w v :complex. z / v + w / v = (z + w) / v``,
+  REWRITE_TAC[complex_div, GSYM COMPLEX_ADD_RDISTRIB]);
+
+val COMPLEX_DIV_SUB = store_thm("COMPLEX_DIV_SUB",
+  ``!z w v :complex. z / v - w / v = (z - w) / v ``,
+  REWRITE_TAC[complex_div, GSYM COMPLEX_SUB_RDISTRIB]);
+
+val COMPLEX_DIV_RMUL_CANCEL = store_thm ("COMPLEX_DIV_RMUL_CANCEL",
+  ``!v:complex z w. ~(v = 0) ==> ((z * v) / (w * v) = z / w)``,
+  RW_TAC boolSimps.bool_ss [complex_div] THEN
+  Cases_on `w = 0` THEN
+  RW_TAC boolSimps.bool_ss [COMPLEX_MUL_LZERO, COMPLEX_INV_0, COMPLEX_INV_MUL, COMPLEX_MUL_RZERO, COMPLEX_EQ_LMUL, GSYM COMPLEX_MUL_ASSOC] THEN
+  DISJ2_TAC THEN ONCE_REWRITE_TAC [COMPLEX_MUL_COMM] THEN
+  ONCE_REWRITE_TAC [GSYM COMPLEX_MUL_ASSOC] THEN
+  RW_TAC boolSimps.bool_ss [COMPLEX_MUL_LINV, COMPLEX_MUL_RID]);
+
+val COMPLEX_DIV_LMUL_CANCEL = store_thm("COMPLEX_DIV_LMUL_CANCEL",
+   ``!v:complex z w. ~(v = 0) ==> ((v * z) / (v * w) = z / w)``,
+   METIS_TAC [COMPLEX_DIV_RMUL_CANCEL, COMPLEX_MUL_COMM]);
+
+val COMPLEX_DIV_DENOM_CANCEL=store_thm("COMPLEX_DIV_DENOM_CANCEL",
+  ``!z:complex w v. ~(z = 0) ==> ((w / z) / (v / z) = w / v)``,
+  RW_TAC boolSimps.bool_ss [complex_div] THEN
+  (Cases_on `w = 0` THEN1 RW_TAC boolSimps.bool_ss [COMPLEX_MUL_LZERO]) THEN
+  (Cases_on `v = 0` THEN1 RW_TAC boolSimps.bool_ss [COMPLEX_INV_0, COMPLEX_MUL_RZERO, COMPLEX_MUL_LZERO]) THEN
+  RW_TAC boolSimps.bool_ss [COMPLEX_INV_MUL, COMPLEX_INV_EQ_0, COMPLEX_INVINV] THEN
+  REWRITE_TAC [GSYM COMPLEX_MUL_ASSOC] THEN
+  RW_TAC boolSimps.bool_ss [COMPLEX_EQ_LMUL] THEN
+  ONCE_REWRITE_TAC [COMPLEX_MUL_COMM] THEN
+  REWRITE_TAC [GSYM COMPLEX_MUL_ASSOC] THEN
+  RW_TAC boolSimps.bool_ss [COMPLEX_MUL_RINV, COMPLEX_MUL_RID]);
+
+val COMPLEX_DIV_INNER_CANCEL = store_thm("COMPLEX_DIV_INNER_CANCEL",
+   ``!z:complex w v. ~(z = 0) ==> ((w / z) * (z / v) = w / v)``,
+  RW_TAC boolSimps.bool_ss [complex_div] THEN
+  (Cases_on `w = 0` THEN1 RW_TAC boolSimps.bool_ss [COMPLEX_MUL_LZERO]) THEN
+  REWRITE_TAC[GSYM COMPLEX_MUL_ASSOC] THEN
+  RW_TAC boolSimps.bool_ss [COMPLEX_EQ_LMUL] THEN
+  REWRITE_TAC[COMPLEX_MUL_ASSOC] THEN
+  RW_TAC boolSimps.bool_ss [COMPLEX_MUL_LINV, COMPLEX_MUL_LID]);
+
+val COMPLEX_DIV_OUTER_CANCEL = store_thm("COMPLEX_DIV_OUTER_CANCEL",
+   ``!z:complex w v. ~(z = 0) ==> ((z /w) * (v / z) = v / w)``,
+  ONCE_REWRITE_TAC[COMPLEX_MUL_COMM] THEN
+  REWRITE_TAC[COMPLEX_DIV_INNER_CANCEL]);
+
+val COMPLEX_DIV_MUL2 = store_thm("COMPLEX_DIV_MUL2",
+  ``!z:complex w.
+      ~(z = 0) /\ ~(w = 0) ==> !v. v / w = (z * v) / (z * w)``,
+  REPEAT GEN_TAC THEN DISCH_TAC THEN GEN_TAC THEN
+  RW_TAC boolSimps.bool_ss [COMPLEX_DIV_LMUL_CANCEL]);
+
+val COMPLEX_ADD_RAT = store_thm ("COMPLEX_ADD_RAT",
+   ``!z:complex w u v.
+       ~(w = 0) /\ ~(v = 0) ==>
+         (z / w + u / v = (z * v + w * u) / (w * v))``,
+   RW_TAC boolSimps.bool_ss [GSYM COMPLEX_DIV_ADD, COMPLEX_DIV_RMUL_CANCEL, COMPLEX_DIV_LMUL_CANCEL]);
+
+val COMPLEX_SUB_RAT = store_thm ("COMPLEX_SUB_RAT",
+  ``!z:complex w u v.
+       ~(w = 0) /\ ~(v = 0) ==>
+       (z / w - u / v = (z * v - w * u) / (w * v))``,
+   RW_TAC boolSimps.bool_ss [complex_sub, COMPLEX_NEG_LDIV]
+   THEN METIS_TAC [COMPLEX_ADD_RAT, COMPLEX_NEG_LMUL, COMPLEX_NEG_RMUL]);
+
+val COMPLEX_DIV_LZERO = store_thm("COMPLEX_DIV_LZERO",
+  ``!z:complex. 0 / z = 0``,
+  REWRITE_TAC[complex_div, COMPLEX_MUL_LZERO] );
+
+val COMPLEX_DIV_REFL = store_thm("COMPLEX_DIV_REFL",
+  ``!z:complex. ~(z = 0) ==> (z / z = 1)``,
+  REWRITE_TAC[complex_div, COMPLEX_MUL_RINV] );
+
+val COMPLEX_SUB_INV2 = store_thm("COMPLEX_SUB_INV2",
+  ``!z:complex w.
+        (z <> 0 /\ w <> 0) ==>
+              (inv z - inv w = (w - z) / (z * w))``,
+  REWRITE_TAC[complex_div] THEN REPEAT STRIP_TAC THEN
+  IMP_RES_TAC COMPLEX_INV_MUL THEN ASM_REWRITE_TAC[] THEN
+  REWRITE_TAC [COMPLEX_SUB_RDISTRIB, COMPLEX_MUL_ASSOC] THEN
+  IMP_RES_TAC COMPLEX_MUL_RINV THEN ASM_REWRITE_TAC[] THEN
+  REWRITE_TAC [COMPLEX_MUL_LID, GSYM COMPLEX_MUL_ASSOC] THEN
+  ONCE_REWRITE_TAC [COMPLEX_MUL_COMM] THEN
+  REWRITE_TAC [GSYM COMPLEX_MUL_ASSOC] THEN
+  FIRST_ASSUM (fn th=> REWRITE_TAC [MATCH_MP COMPLEX_MUL_LINV th]) THEN
+  REWRITE_TAC[COMPLEX_MUL_RID]);
+
+val COMPLEX_EQ_RDIV_EQ = store_thm("COMPLEX_EQ_RDIV_EQ",
+  ``!z:complex w:complex v:complex.
+                   ~(v = 0) ==> ((z = w / v) = (z * v= w))``,
+  REPEAT GEN_TAC THEN REWRITE_TAC[complex_div] THEN
+  DISCH_TAC THEN EQ_TAC THENL
+  [DISCH_THEN(MP_TAC o AP_TERM (``$* (v:complex)``)) THEN
+  ONCE_REWRITE_TAC[COMPLEX_MUL_COMM] THEN
+  RW_TAC boolSimps.bool_ss [COMPLEX_MUL_COMM, GSYM COMPLEX_MUL_ASSOC, COMPLEX_MUL_LINV, COMPLEX_MUL_RID],
+  DISCH_THEN(MP_TAC o AP_TERM (``$* (inv v:complex)``)) THEN
+  ONCE_REWRITE_TAC[COMPLEX_MUL_COMM] THEN
+  RW_TAC boolSimps.bool_ss [COMPLEX_MUL_COMM, GSYM COMPLEX_MUL_ASSOC, COMPLEX_MUL_RINV, COMPLEX_MUL_RID]]);
+
+val COMPLEX_EQ_LDIV_EQ = store_thm("COMPLEX_EQ_LDIV_EQ",
+  ``!z:complex w:complex v:complex.
+                ~(v = 0) ==> ((z / v = w) = (z = w * v))``,
+  REPEAT GEN_TAC THEN REWRITE_TAC[complex_div] THEN
+  DISCH_TAC THEN EQ_TAC THENL
+  [DISCH_THEN(MP_TAC o AP_TERM (``$* (v:complex)``)) THEN
+   ONCE_REWRITE_TAC[COMPLEX_MUL_COMM] THEN
+   RW_TAC boolSimps.bool_ss [COMPLEX_MUL_COMM, GSYM COMPLEX_MUL_ASSOC, COMPLEX_MUL_LINV, COMPLEX_MUL_RID],
+   DISCH_THEN(MP_TAC o AP_TERM (``$* (inv v:complex)``)) THEN
+   ONCE_REWRITE_TAC[COMPLEX_MUL_COMM] THEN
+   RW_TAC boolSimps.bool_ss [COMPLEX_MUL_COMM, GSYM COMPLEX_MUL_ASSOC, COMPLEX_MUL_RINV, COMPLEX_MUL_RID]]);
+
+(* ------------------------------------------------------------------ *)
+(* Homomorphic embedding properties for complex_of_real mapping.      *)
+(* ------------------------------------------------------------------ *)
+
+val COMPLEX_OF_REAL_EQ = store_thm("COMPLEX_OF_REAL_EQ",
+  ``!x:real y:real.
+         (complex_of_real x = complex_of_real y) = (x = y)``,
+  REWRITE_TAC[complex_of_real, COMPLEX_RE_IM_EQ, RE, IM]);
+
+val COMPLEX_OF_REAL_ADD = store_thm("COMPLEX_OF_REAL_ADD",
+  ``!x:real y:real.
+     complex_of_real x + complex_of_real y = complex_of_real (x + y)``,
+  REWRITE_TAC [complex_of_real,complex_add,RE,IM,REAL_ADD_RID]);
+
+val COMPLEX_OF_REAL_NEG = store_thm("COMPLEX_OF_REAL_NEG",
+  ``!x:real. -complex_of_real x = complex_of_real (-x)``,
+  REWRITE_TAC [complex_of_real,complex_neg,RE,IM,REAL_NEG_0]);
+
+val COMPLEX_OF_REAL_MUL = store_thm("COMPLEX_OF_REAL_MUL",
+  ``!x:real y:real.
+ complex_of_real x * complex_of_real y = complex_of_real (x * y)``,
+  REWRITE_TAC [complex_of_real, complex_mul, RE, IM, REAL_MUL_RZERO, REAL_MUL_LZERO, REAL_SUB_RZERO, REAL_ADD_RID]);
+
+val COMPLEX_OF_REAL_INV = store_thm("COMPLEX_OF_REAL_INV",
+  ``!x:real. inv (complex_of_real x) = complex_of_real (inv x)``,
+  GEN_TAC THEN ASM_CASES_TAC (``x = 0r``) THEN RW_TAC real_ss [complex_inv, complex_of_real, REAL_INV_0, RE, IM, POW_2, REAL_MUL_RZERO, REAL_ADD_RID, real_div, REAL_MUL_LZERO, REAL_NEG_0, REAL_INV_MUL, REAL_MUL_ASSOC, REAL_MUL_RINV, REAL_MUL_LID]);
+
+val COMPLEX_OF_REAL_SUB = store_thm("COMPLEX_OF_REAL_SUB",
+  ``!x:real y:real.
+      complex_of_real x - complex_of_real y = complex_of_real (x - y)``,
+  REWRITE_TAC [real_sub, COMPLEX_OF_REAL_ADD, COMPLEX_OF_REAL_NEG, complex_sub]);
+
+val COMPLEX_OF_REAL_DIV = store_thm("COMPLEX_OF_REAL_DIV",
+  ``!x:real y:real.
+      complex_of_real x / complex_of_real y =  complex_of_real (x / y)``,
+  REWRITE_TAC [real_div, COMPLEX_OF_REAL_MUL, COMPLEX_OF_REAL_INV, complex_div]);
+
+(* ------------------------------------------------------------------ *)
+(* Homomorphic embedding properties for complex_of_num mapping.       *)
+(* ------------------------------------------------------------------ *)
+
+val COMPLEX_OF_NUM_EQ = store_thm("COMPLEX_OF_NUM_EQ",
+``!m:num n:num. (complex_of_num m = complex_of_num n) = (m = n)``,
+  REWRITE_TAC[complex_of_num, COMPLEX_OF_REAL_EQ,REAL_OF_NUM_EQ]);
+
+val COMPLEX_OF_NUM_ADD = store_thm("COMPLEX_OF_NUM_ADD",
+  ``!m:num n:num.
+     complex_of_num m + complex_of_num n = complex_of_num (m + n)``,
+  REWRITE_TAC [complex_of_num, REAL_OF_NUM_ADD, COMPLEX_OF_REAL_ADD]);
+
+val COMPLEX_OF_NUM_MUL = store_thm("COMPLEX_OF_NUM_MUL",
+  ``!m:num n:num.
+ complex_of_num m * complex_of_num n = complex_of_num (m * n)``,
+  REWRITE_TAC [complex_of_num, REAL_OF_NUM_MUL, COMPLEX_OF_REAL_MUL]);
+
+(* ------------------------------------------------------------------ *)
+(* A tactical to automate very simple algebraic equivalences.         *)
+(* ------------------------------------------------------------------ *)
+
+val SIMPLE_COMPLEX_ARITH_TAC =
+  REWRITE_TAC[COMPLEX_RE_IM_EQ, RE, IM, complex_of_real, complex_add, complex_neg, complex_sub, complex_mul] THEN REAL_ARITH_TAC;
+
+(*--------------------------------------------------------------------*)
+(* Define the left scalar multiplication                              *)
+(* and right scalar multiplication                                    *)
+(*--------------------------------------------------------------------*)
+
+val complex_scalar_lmul = new_definition
+("complex_scalar_lmul",
+``complex_scalar_lmul (k:real) (z:complex) = (k * RE z,k * IM z)``);
+
+val complex_scalar_rmul = new_definition
+("complex_scalar_rmul",
+``complex_scalar_rmul (z:complex) (k:real) = (RE z * k,IM z * k)``);
+
+val _ = overload_on ("*",  Term`$complex_scalar_lmul`);
+val _ = overload_on ("*",  Term`$complex_scalar_rmul`);
+
+(*--------------------------------------------------------------------*)
+(* The properities of R-module                                        *)
+(*--------------------------------------------------------------------*)
+
+
+val COMPLEX_SCALAR_LMUL = store_thm("COMPLEX_SCALAR_LMUL",
+  ``!k:real l:real z:complex. k * (l * z) = k * l * z``,
+  REWRITE_TAC[complex_scalar_lmul, RE,IM,REAL_MUL_ASSOC]);
+
+val COMPLEX_SCALAR_LMUL_NEG = store_thm("COMPLEX_SCALAR_LMUL_NEG",
+  ``!k:real z:complex. -(k * z) = -k * z``,
+  REWRITE_TAC[complex_scalar_lmul,complex_neg,RE,IM,REAL_NEG_LMUL]);
+
+val COMPLEX_NEG_SCALAR_LMUL = store_thm("COMPLEX_NEG_SCALAR_LMUL",
+  ``!k:real z:complex. k * (-z) = -k * z``,
+  REWRITE_TAC [complex_neg, complex_scalar_lmul, RE, IM, REAL_MUL_LNEG, REAL_MUL_RNEG]);
+
+val COMPLEX_SCALAR_LMUL_ADD = store_thm("COMPLEX_SCALAR_LMUL_ADD",
+  ``!k:real l:real z:complex. (k + l) * z = k * z + l * z``,
+  REWRITE_TAC[complex_add,complex_scalar_lmul,RE,IM,GSYM REAL_ADD_RDISTRIB]);
+
+val COMPLEX_SCALAR_LMUL_SUB = store_thm("COMPLEX_SCALAR_LMUL_SUB",
+  ``!k:real l:real z:complex. (k - l) * z = k * z - l * z``,
+  REWRITE_TAC [complex_sub, COMPLEX_SCALAR_LMUL_NEG, GSYM COMPLEX_SCALAR_LMUL_ADD, real_sub]);
+
+val COMPLEX_ADD_SCALAR_LMUL = store_thm("COMPLEX_ADD_SCALAR_LMUL",
+  ``!k:real z:complex w:complex. k * (z + w) = k * z + k * w``,
+  REWRITE_TAC[complex_add, complex_scalar_lmul, RE, IM, GSYM REAL_ADD_LDISTRIB]);
+
+val COMPLEX_SUB_SCALAR_LMUL = store_thm("COMPLEX_SUB_SCALAR_LMUL",
+  ``!k:real z:complex w:complex. k * (z - w) = k * z - k * w``,
+  REWRITE_TAC[complex_sub, COMPLEX_ADD_SCALAR_LMUL, COMPLEX_NEG_SCALAR_LMUL, COMPLEX_SCALAR_LMUL_NEG]);
+
+val COMPLEX_MUL_SCALAR_LMUL2 = store_thm("COMPLEX_MUL_SCALAR_LMUL2",
+  ``!k:real l:real z:complex w:complex.
+                (k * z) * (l * w) = (k * l) * (z * w)``,
+  REWRITE_TAC [complex_mul, complex_scalar_lmul, RE, IM, PAIR_EQ] THEN REAL_ARITH_TAC);
+
+val COMPLEX_LMUL_SCALAR_LMUL = store_thm("COMPLEX_LMUL_SCALAR_LMUL",
+  ``!k:real z:complex w:complex. (k * z) * w = k * (z * w)``,
+  REWRITE_TAC [complex_mul, complex_scalar_lmul, RE, IM, PAIR_EQ] THEN REAL_ARITH_TAC);
+
+val COMPLEX_RMUL_SCALAR_LMUL = store_thm("COMPLEX_RMUL_SCALAR_LMUL",
+  ``!k:real z:complex w:complex. z * (k * w) = k * (z * w)``,
+  PROVE_TAC[COMPLEX_MUL_COMM, COMPLEX_LMUL_SCALAR_LMUL]);
+
+val COMPLEX_SCALAR_LMUL_ZERO = store_thm("COMPLEX_SCALAR_LMUL_ZERO",
+  ``!z:complex. 0r * z = 0``,
+  REWRITE_TAC[complex_of_num, complex_of_real, complex_scalar_lmul, REAL_MUL_LZERO]);
+
+val COMPLEX_ZERO_SCALAR_LMUL = store_thm("COMPLEX_ZERO_SCALAR_LMUL",
+  ``!k:real. k * 0 = 0``,
+  REWRITE_TAC[complex_of_num, complex_of_real, complex_scalar_lmul, RE, IM, REAL_MUL_RZERO]);
+
+val COMPLEX_SCALAR_LMUL_ONE = store_thm("COMPLEX_SCALAR_LMUL_ONE",
+  ``!z:complex. 1r * z = z``,
+  REWRITE_TAC[complex_scalar_lmul, REAL_MUL_LID,RE,IM]);
+
+val COMPLEX_SCALAR_LMUL_NEG1 = store_thm ("COMPLEX_SCALAR_LMUL_NEG1",
+  ``!z:complex. -1r * z = -z``,
+  GEN_TAC THEN REWRITE_TAC[GSYM COMPLEX_SCALAR_LMUL_NEG] THEN
+  REWRITE_TAC[COMPLEX_SCALAR_LMUL_ONE]);
+
+val COMPLEX_DOUBLE = store_thm ("COMPLEX_DOUBLE",
+  ``!z:complex. z + z = &2 * z``,
+  GEN_TAC THEN REWRITE_TAC[num_CONV ``2:num``, REAL] THEN
+  REWRITE_TAC[COMPLEX_SCALAR_LMUL_ADD, COMPLEX_SCALAR_LMUL_ONE]);
+
+val COMPLEX_SCALAR_LMUL_ENTIRE = store_thm("COMPLEX_SCALAR_LMUL_ENTIRE",
+  ``!k:real z:complex. (k * z = 0) = (k = 0) \/ (z = 0)``,
+  REWRITE_TAC[COMPLEX_0_THM, complex_scalar_lmul, RE,IM, POW_2, REAL_SUMSQ, REAL_ENTIRE, GSYM LEFT_OR_OVER_AND]);
+
+val COMPLEX_EQ_SCALAR_LMUL = store_thm("COMPLEX_EQ_SCALAR_LMUL",
+  ``!k:real z:complex w:complex. (k * z = k * w) = (k = 0) \/ (z = w)``,
+  ONCE_REWRITE_TAC [GSYM COMPLEX_SUB_0] THEN REWRITE_TAC [GSYM COMPLEX_SUB_SCALAR_LMUL, COMPLEX_SCALAR_LMUL_ENTIRE]);
+
+val COMPLEX_SCALAR_LMUL_EQ = store_thm("COMPLEX_SCALAR_LMUL_EQ",
+  ``!k:real l:real z:complex.
+                    (k * z = l * z) = (k = l) \/ (z = 0)``,
+  ONCE_REWRITE_TAC [GSYM COMPLEX_SUB_0] THEN
+  REWRITE_TAC [GSYM COMPLEX_SCALAR_LMUL_SUB, COMPLEX_SCALAR_LMUL_ENTIRE, COMPLEX_SUB_RZERO, REAL_SUB_0]);
+
+val COMPLEX_SCALAR_LMUL_EQ1 = store_thm("COMPLEX_SCALAR_LMUL_EQ1",
+  ``!k:real z:complex. (k * z = z) = (k = 1) \/ (z = 0)``,
+  PROVE_TAC[COMPLEX_SCALAR_LMUL_ONE,COMPLEX_SCALAR_LMUL_EQ]);
+
+val COMPLEX_INV_SCALAR_LMUL = store_thm("COMPLEX_INV_SCALAR_LMUL",
+  ``!k:real z:complex.
+          (k <> 0 /\ z <> 0) ==> (inv (k * z) = inv k * inv z)``,
+  REWRITE_TAC [COMPLEX_0_THM, complex_inv,complex_scalar_lmul,RE,IM, POW_MUL, GSYM REAL_ADD_LDISTRIB, real_div, REAL_INV_MUL] THEN
+  REPEAT STRIP_TAC THEN
+  `k pow 2 <> 0` by RW_TAC real_ss[POW_2, REAL_ENTIRE] THEN
+  RW_TAC real_ss[REAL_INV_MUL] THEN
+  `inv (k pow 2) = inv k * inv k` by RW_TAC real_ss[POW_2, REAL_INV_MUL] THEN
+  ASM_REWRITE_TAC[REAL_MUL_ASSOC] THENL[
+  `k * FST z * inv k * inv k = inv k * k * FST z * inv k` by REAL_ARITH_TAC,
+  `k * SND z * inv k * inv k = inv k * k * SND z * inv k` by REAL_ARITH_TAC] THEN
+  ASM_REWRITE_TAC[] THEN RW_TAC real_ss[REAL_MUL_LINV,REAL_MUL_COMM]);
+
+val COMPLEX_SCALAR_LMUL_DIV2 = store_thm("COMPLEX_SCALAR_LMUL_DIV2",
+  ``!k l :real z w :complex.
+   (l <> 0 /\ w <> 0) ==> ((k * z) / (l * w) = (k / l) * (z / w))``,
+  REWRITE_TAC [complex_div] THEN REPEAT STRIP_TAC THEN
+  IMP_RES_TAC COMPLEX_INV_SCALAR_LMUL THEN ASM_REWRITE_TAC[] THEN
+  REWRITE_TAC [COMPLEX_MUL_SCALAR_LMUL2, real_div]);
+
+val COMPLEX_SCALAR_MUL_COMM = store_thm("COMPLEX_SCALAR_MUL_COMM",
+  ``!k:real z:complex. k * z = z * k ``,
+  PROVE_TAC[complex_scalar_lmul, complex_scalar_rmul, REAL_MUL_COMM]);
+
+val COMPLEX_SCALAR_RMUL = store_thm("COMPLEX_SCALAR_RMUL",
+  ``!k:real l:real z:complex. z * k * l = z * (k * l)``,
+  RW_TAC bool_ss [GSYM COMPLEX_SCALAR_MUL_COMM, COMPLEX_SCALAR_LMUL, REAL_MUL_COMM]);
+
+val COMPLEX_SCALAR_RMUL_NEG = store_thm("COMPLEX_SCALAR_RMUL_NEG",
+  ``!k:real z:complex. -(z * k) = z * -k ``,
+  REWRITE_TAC [GSYM COMPLEX_SCALAR_MUL_COMM, COMPLEX_SCALAR_LMUL_NEG]);
+
+val COMPLEX_NEG_SCALAR_RMUL = store_thm("COMPLEX_NEG_SCALAR_RMUL",
+  ``!k:real z:complex. (-z) * k = z * -k``,
+  REWRITE_TAC [GSYM COMPLEX_SCALAR_MUL_COMM, COMPLEX_NEG_SCALAR_LMUL]);
+
+val COMPLEX_SCALAR_RMUL_ADD = store_thm("COMPLEX_SCALAR_RMUL_ADD",
+  ``!k:real l:real z:complex. z * (k + l) = z * k + z * l``,
+  REWRITE_TAC [GSYM COMPLEX_SCALAR_MUL_COMM, COMPLEX_SCALAR_LMUL_ADD]);
+
+val COMPLEX_SCALAR_RMUL_SUB = store_thm("COMPLEX_RSCALAR_RMUL_SUB",
+  ``!k: real l:real z:complex. z * (k - l) = z * k - z * l ``,
+  REWRITE_TAC [GSYM COMPLEX_SCALAR_MUL_COMM, COMPLEX_SCALAR_LMUL_SUB]);
+
+val COMPLEX_ADD_SCALAR_RMUL = store_thm("COMPLEX_ADD_RSCALAR_RMUL",
+  ``!k:real z:complex w:complex. (z + w) * k = z * k + w * k``,
+  REWRITE_TAC [GSYM COMPLEX_SCALAR_MUL_COMM, COMPLEX_ADD_SCALAR_LMUL]);
+
+val COMPLEX_SUB_SCALAR_RMUL = store_thm("COMPLEX_SUB_SCALAR_RMUL",
+  ``!k:real z:complex w:complex. (z - w) * k = z * k - w * k ``,
+  REWRITE_TAC [GSYM COMPLEX_SCALAR_MUL_COMM, COMPLEX_SUB_SCALAR_LMUL]);
+
+val COMPLEX_SCALAR_RMUL_ZERO = store_thm("COMPLEX_SCALAR_RMUL_ZERO",
+  ``!z:complex. z * 0r = 0``,
+  REWRITE_TAC[complex_of_num, complex_of_real, complex_scalar_rmul, REAL_MUL_RZERO]);
+
+val COMPLEX_ZERO_SCALAR_RMUL = store_thm("COMPLEX_ZERO_SCALAR_RMUL",
+  ``!k:real. 0 * k = 0``,
+  REWRITE_TAC [GSYM COMPLEX_SCALAR_MUL_COMM, COMPLEX_ZERO_SCALAR_LMUL]);
+
+val COMPLEX_SCALAR_RMUL_ONE = store_thm("COMPLEX_SCALAR_RMUL_ONE",
+  ``!z:complex. z * 1r = z``,
+  REWRITE_TAC [GSYM COMPLEX_SCALAR_MUL_COMM, COMPLEX_SCALAR_LMUL_ONE]);
+
+val COMPLEX_SCALAR_RMUL_NEG1 = store_thm ("COMPLEX_SCALAR_RMUL_NEG1",
+  ``!z:complex. z * -1r = -z``,
+  REWRITE_TAC [GSYM COMPLEX_SCALAR_MUL_COMM, COMPLEX_SCALAR_LMUL_NEG1]);
+
+(*--------------------------------------------------------------------*)
+(* Complex conjugate                                                  *)
+(*--------------------------------------------------------------------*)
+
+val conj = new_definition
+     ("conj", ``conj (z:complex) = (RE z, -IM z)``);
+
+val CONJ_REAL_REFL= store_thm("CONJ_REAL_REFL",
+  ``!x:real. conj (complex_of_real x) = complex_of_real x``,
+  REWRITE_TAC[complex_of_real,conj, RE,IM, REAL_NEG_0]);
+
+val CONJ_NUM_REFL= store_thm("CONJ_NUM_REFL",
+  ``!n:num. conj (complex_of_num n) = complex_of_num n``,
+  REWRITE_TAC[complex_of_num,CONJ_REAL_REFL]);
+
+val CONJ_ADD = store_thm("CONJ_ADD",
+  ``!z:complex w:complex. conj (z + w) = conj z + conj w``,
+  REWRITE_TAC [conj,complex_add,RE,IM,REAL_NEG_ADD]);
+
+val CONJ_NEG = store_thm("CONJ_NEG",
+  ``!z:complex. conj (-z) = -conj z ``,
+  REWRITE_TAC [complex_neg, conj,RE,IM]);
+
+val CONJ_SUB = store_thm("CONJ_SUB",
+  ``!z:complex w:complex. conj (z - w) = conj z - conj w``,
+  REWRITE_TAC [complex_sub, CONJ_NEG, CONJ_ADD]);
+
+val CONJ_MUL = store_thm("CONJ_MUL",
+  ``!z:complex w:complex. conj (z * w) = conj z * conj w``,
+  REWRITE_TAC [conj,complex_mul, RE,IM,REAL_NEG_ADD, REAL_NEG_MUL2, GSYM REAL_NEG_LMUL, GSYM REAL_NEG_RMUL]);
+
+val CONJ_INV = store_thm("CONJ_INV",
+  ``!z: complex. conj (inv z) = inv (conj z)``,
+  RW_TAC real_ss [conj, complex_inv, RE, IM, POW_2, real_div]);
+
+val CONJ_DIV= store_thm("CONJ_DIV",
+  ``!z:complex w. conj (z / w) = conj z / conj w``,
+  REWRITE_TAC[complex_div, CONJ_MUL, CONJ_INV]);
+
+val CONJ_SCALAR_LMUL = store_thm("CONJ_SCALAR_LMUL",
+  ``!k:real z:complex. conj (k * z) = k * conj z``,
+  REWRITE_TAC [conj,complex_scalar_lmul, RE,IM,REAL_MUL_RNEG]);
+
+val CONJ_CONJ = store_thm("CONJ_CONJ",
+  ``!z:complex. conj (conj z) = z``,
+  REWRITE_TAC[conj, RE,IM,REAL_NEGNEG]);
+
+val CONJ_EQ = store_thm("CONJ_EQ",
+  ``!z:complex w:complex. (conj z = w) = (z = conj w)``,
+  REWRITE_TAC [conj, COMPLEX_RE_IM_EQ, RE, IM, REAL_NEG_EQ]);
+
+val CONJ_EQ2 = store_thm("CONJ_EQ2",
+  ``!z:complex w:complex. (conj z = conj w) = (z = w)``,
+  REWRITE_TAC [CONJ_EQ, CONJ_CONJ]);
+
+val COMPLEX_MUL_RCONJ = store_thm("COMPLEX_MUL_RCONJ",
+  ``!z:complex.
+         z * conj z = complex_of_real ((RE z) pow 2 + (IM z) pow 2)``,
+  REWRITE_TAC [complex_mul, conj, complex_of_real, RE, IM, REAL_MUL_RNEG, REAL_SUB_RNEG] THEN
+  PROVE_TAC [POW_2, REAL_MUL_COMM, REAL_ADD_LINV]);
+
+val COMPLEX_MUL_LCONJ = store_thm("COMPLEX_MUL_RCONJ",
+  ``!z:complex.
+         conj z * z = complex_of_real ((RE z) pow 2 + (IM z) pow 2)``,
+  PROVE_TAC [COMPLEX_MUL_COMM, COMPLEX_MUL_RCONJ]);
+
+val CONJ_ZERO = store_thm("CONJ_ZERO",
+  ``conj 0 = 0``,
+  REWRITE_TAC [CONJ_NUM_REFL]);
+
+(*--------------------------------------------------------------------*)
+(* Define modulus and  argument principal value of complex            *)
+(*--------------------------------------------------------------------*)
+
+val modu = new_definition("modu",
+  ``modu (z:complex) = sqrt( RE z pow 2 + IM z pow 2)``);
+
+val arg = new_definition("arg",
+  ``arg z =
+       if 0 <= IM z then acs (RE z / modu z)
+                   else -acs (RE z / modu z) + 2 * pi``);
+
+(*--------------------------------------------------------------------*)
+(* The properities of  modulus and  argument principal value          *)
+(*--------------------------------------------------------------------*)
+
+val MODU_POW2 = store_thm("MODU_POW2",
+  ``!z:complex. modu z pow 2 = RE z pow 2 + IM z pow 2 ``,
+  REWRITE_TAC[modu] THEN
+  PROVE_TAC [REAL_LE_POW2, REAL_LE_ADD, SQRT_POW_2]);
+
+val RE_IM_LE_MODU= store_thm("RE_IM_LE_MODU",
+  ``!z:complex. abs (RE z) <= modu z /\ abs (IM z) <= modu z``,
+  REWRITE_TAC [modu] THEN GEN_TAC THEN CONJ_TAC THENL
+  [REWRITE_TAC [COMPLEX_LEMMA2],
+  ONCE_REWRITE_TAC [REAL_ADD_COMM] THEN REWRITE_TAC [COMPLEX_LEMMA2]]);
+
+val MODU_POS= store_thm("MODU_POS",
+  ``!z:complex. 0 <= modu z``,
+  GEN_TAC THEN REWRITE_TAC[modu] THEN MATCH_MP_TAC SQRT_POS_LE THEN
+  MATCH_MP_TAC REAL_LE_ADD THEN REWRITE_TAC[REAL_LE_POW2]);
+
+val COMPLEX_MUL_RCONJ1 = store_thm("COMPLEX_MUL_RCONJ1",
+  ``!z:complex. z * conj z = complex_of_real ((modu z) pow 2)``,
+  REWRITE_TAC[COMPLEX_MUL_RCONJ, MODU_POW2]);
+
+val COMPLEX_MUL_LCONJ1 = store_thm("COMPLEX_MUL_LCONJ1",
+  ``!z:complex. conj z * z = complex_of_real ((modu z) pow 2)``,
+  REWRITE_TAC[COMPLEX_MUL_LCONJ, MODU_POW2]);
+
+val MODU_NEG = store_thm("MODU_NEG",
+  ``!z:complex. modu (-z) = modu z``,
+  REWRITE_TAC[modu,complex_neg,RE,IM,POW_2,REAL_NEG_MUL2]);
+
+val MODU_SUB = store_thm("MODU_SUB",
+  ``!z:complex w:complex. modu (z - w) = modu (w - z)``,
+  REPEAT GEN_TAC THEN
+  `w - z = -(z - w)` by REWRITE_TAC[COMPLEX_NEG_SUB] THEN
+  ASM_REWRITE_TAC[] THEN REWRITE_TAC[MODU_NEG]);
+
+val MODU_CONJ = store_thm("MODU_CONJ",
+  ``!z:complex. modu (conj z) = modu z ``,
+  REWRITE_TAC[modu, conj,RE,IM,POW_2,REAL_NEG_MUL2]);
+
+val MODU_MUL = store_thm("MODU_MUL",
+  ``!z:complex w:complex. modu (z * w) = modu z * modu w``,
+  REWRITE_TAC [modu, complex_mul, RE, IM, COMPLEX_LEMMA1] THEN
+  PROVE_TAC [REAL_LE_POW2, REAL_LE_ADD, SQRT_MUL]);
+
+val MODU_0 = store_thm("MODU_0",
+  ``modu 0 = 0 ``,
+  REWRITE_TAC[complex_of_num,complex_of_real, modu, RE, IM, POW_2, REAL_MUL_RZERO, REAL_ADD_RID, SQRT_0]);
+
+val MODU_1 = store_thm("MODU_1",
+  ``modu 1 = 1 ``,
+  REWRITE_TAC[complex_of_num,complex_of_real, modu, RE, IM, POW_2, REAL_MUL_RID, REAL_MUL_RZERO, REAL_ADD_RID, SQRT_1]);
+
+val MODU_COMPLEX_INV = store_thm("MODU_COMPLEX_INV",
+  ``!z: complex. z <> 0 ==> (modu (inv z) = inv (modu z)) ``,
+  REPEAT STRIP_TAC THEN MATCH_MP_TAC REAL_LINV_UNIQ THEN
+  REWRITE_TAC[GSYM MODU_MUL] THEN
+  FIRST_ASSUM(fn th => REWRITE_TAC[MATCH_MP COMPLEX_MUL_LINV th]) THEN
+  REWRITE_TAC [MODU_1]);
+
+val MODU_DIV = store_thm("MODU_DIV",
+  ``!z w : complex. (w <> 0) ==> (modu(z / w) = modu z / modu w) ``,
+  REWRITE_TAC[complex_div, MODU_MUL] THEN REPEAT STRIP_TAC THEN
+  FIRST_ASSUM(fn th => REWRITE_TAC[MATCH_MP MODU_COMPLEX_INV th]) THEN
+  REWRITE_TAC[real_div]);
+
+val MODU_SCALAR_LMUL = store_thm("MODU_SCALAR_LMUL",
+  ``!k:real z:complex. modu (k * z) = abs k * modu z``,
+  REWRITE_TAC [modu, complex_scalar_lmul, RE, IM, POW_MUL, GSYM REAL_ADD_LDISTRIB] THEN
+  ONCE_REWRITE_TAC [GSYM REAL_POW2_ABS] THEN
+  PROVE_TAC[REAL_ABS_POS,REAL_LE_POW2,REAL_LE_ADD,SQRT_MUL,POW_2_SQRT]);
+
+val MODU_REAL = store_thm("MODU_REAL",
+  ``!x:real. modu (complex_of_real x) = abs x``,
+  REWRITE_TAC [complex_of_real, modu, RE, IM, POW_2, REAL_MUL_RZERO, REAL_ADD_RID] THEN
+  REWRITE_TAC [GSYM POW_2] THEN
+  ONCE_REWRITE_TAC [GSYM REAL_POW2_ABS] THEN GEN_TAC THEN
+  `0 <= abs x` by PROVE_TAC [REAL_ABS_POS] THEN
+  FIRST_ASSUM (fn th => REWRITE_TAC [MATCH_MP POW_2_SQRT th]));
+
+val MODU_NUM = store_thm("MODU_NUM",
+  ``!n:num. modu (complex_of_num n) = &n``,
+  REWRITE_TAC [complex_of_num, MODU_REAL, ABS_N]);
+
+val MODU_ZERO= store_thm("MODU_ZERO",
+  ``!z:complex. (z = 0) = (modu z = 0)``,
+  GEN_TAC THEN EQ_TAC THEN DISCH_TAC THEN
+  ASM_REWRITE_TAC[MODU_0, COMPLEX_0_THM, GSYM MODU_POW2, num_CONV (``2:num``),POW_0]);
+
+val MODU_NZ = store_thm("MODU_NZ",
+  (``!z:complex. (z <> 0) = 0 < modu z ``),
+  GEN_TAC THEN EQ_TAC THENL
+   [REWRITE_TAC[MODU_ZERO] THEN
+    DISCH_TAC THEN
+    PROVE_TAC[REAL_LE_LT, MODU_POS],
+    CONV_TAC CONTRAPOS_CONV THEN REWRITE_TAC[] THEN
+    DISCH_THEN SUBST1_TAC THEN
+    REWRITE_TAC[MODU_0, REAL_LT_REFL]]);
+
+val MODU_CASES = store_thm("MODU_CASES",
+  ``!z:complex. (z = 0) \/ 0 < modu z``,
+  GEN_TAC THEN REWRITE_TAC[GSYM MODU_NZ] THEN
+  BOOL_CASES_TAC ``z = 0`` THEN ASM_REWRITE_TAC[]);
+
+val RE_DIV_MODU_BOUNDS = store_thm("RE_DIV_MODU_BOUNDS",
+  ``!z:complex.
+       z <> 0 ==> (-1 <= RE z / modu z /\ RE z / modu z <= 1) ``,
+  GEN_TAC THEN DISCH_TAC THEN CONJ_TAC THENL
+  [MATCH_MP_TAC REAL_LE_RDIV THEN CONJ_TAC THENL
+  [PROVE_TAC[MODU_NZ],
+  REWRITE_TAC[REAL_MUL_LNEG,REAL_MUL_LID] THEN
+  PROVE_TAC[RE_IM_LE_MODU,ABS_BOUNDS]],
+  MATCH_MP_TAC REAL_LE_LDIV THEN CONJ_TAC THENL
+  [PROVE_TAC[MODU_NZ],
+  REWRITE_TAC[REAL_MUL_LNEG,REAL_MUL_LID] THEN
+  PROVE_TAC[RE_IM_LE_MODU,ABS_BOUNDS]]
+  ]);
+
+val IM_DIV_MODU_BOUNDS = store_thm("IM_DIV_MODU_BOUNDS",
+  ``!z:complex.
+       z <> 0 ==> (-1 <= IM z / modu z /\ IM z / modu z <= 1)``,
+  GEN_TAC THEN DISCH_TAC THEN CONJ_TAC THENL
+  [MATCH_MP_TAC REAL_LE_RDIV THEN CONJ_TAC THENL
+  [PROVE_TAC[MODU_NZ],
+  REWRITE_TAC[REAL_MUL_LNEG,REAL_MUL_LID] THEN
+  PROVE_TAC[RE_IM_LE_MODU,ABS_BOUNDS]],
+  MATCH_MP_TAC REAL_LE_LDIV THEN CONJ_TAC THENL
+  [PROVE_TAC[MODU_NZ],
+  REWRITE_TAC[REAL_MUL_LID] THEN
+  PROVE_TAC[RE_IM_LE_MODU,ABS_BOUNDS]]
+]);
+
+val RE_DIV_MODU_ACS_BOUNDS = store_thm("RE_DIV_MODU_ACS_BOUNDS",
+  ``!z:complex.
+    z <> 0 ==>
+        (0 <=acs (RE z / modu z) /\ acs (RE z / modu z) <= pi)``,
+  GEN_TAC THEN DISCH_TAC THEN MATCH_MP_TAC ACS_BOUNDS THEN
+  POP_ASSUM MP_TAC THEN MATCH_ACCEPT_TAC RE_DIV_MODU_BOUNDS);
+
+val IM_DIV_MODU_ASN_BOUNDS = store_thm("IM_DIV_MODU_ASN_BOUNDS",
+  ``!z:complex.
+   z <> 0 ==>
+   (-(pi/2) <= asn (IM z / modu z) /\ asn (IM z / modu z) <= pi/2)``,
+  GEN_TAC THEN DISCH_TAC THEN MATCH_MP_TAC ASN_BOUNDS THEN
+  POP_ASSUM MP_TAC THEN MATCH_ACCEPT_TAC IM_DIV_MODU_BOUNDS);
+
+val RE_DIV_MODU_ACS_COS = store_thm("RE_DIV_MODU_ACS_COS",
+  ``!z:complex.
+  z <> 0 ==> (cos ( acs (RE z / modu z)) = RE z / modu z)``,
+  GEN_TAC THEN DISCH_TAC THEN MATCH_MP_TAC ACS_COS THEN
+  POP_ASSUM MP_TAC THEN MATCH_ACCEPT_TAC RE_DIV_MODU_BOUNDS );
+
+val IM_DIV_MODU_ASN_SIN = store_thm("IM_DIV_MODU_ASN_SIN",
+  ``!z:complex.
+       z <> 0 ==> (sin ( asn (IM z / modu z)) = IM z / modu z)``,
+  GEN_TAC THEN DISCH_TAC THEN MATCH_MP_TAC ASN_SIN THEN
+  POP_ASSUM MP_TAC THEN MATCH_ACCEPT_TAC IM_DIV_MODU_BOUNDS);
+
+val ARG_COS = store_thm("ARG_COS",
+  ``!z:complex. z <> 0 ==> (cos (arg z) = RE z / modu z)``,
+  GEN_TAC THEN DISCH_TAC THEN
+  REWRITE_TAC[arg] THEN COND_CASES_TAC THEN
+  REWRITE_TAC[COS_PERIODIC, COS_NEG] THEN
+  MATCH_MP_TAC RE_DIV_MODU_ACS_COS THEN ASM_REWRITE_TAC[]);
+
+val ARG_SIN = store_thm("ARG_SIN",
+  ``!z:complex. z <> 0 ==> (sin (arg z) = IM z / modu z)``,
+  GEN_TAC THEN DISCH_TAC THEN
+  REWRITE_TAC[arg] THEN COND_CASES_TAC THENL
+  [SUBGOAL_THEN (``sin (acs (RE z / modu z)) = sqrt (1 - cos (acs (RE z / modu z)) pow 2)``) ASSUME_TAC THENL
+  [MATCH_MP_TAC SIN_COS_SQ THEN
+  MATCH_MP_TAC RE_DIV_MODU_ACS_BOUNDS THEN
+  ASM_REWRITE_TAC[],
+  ASM_REWRITE_TAC[] THEN
+  FIRST_ASSUM (fn th => REWRITE_TAC [MATCH_MP RE_DIV_MODU_ACS_COS th]) THEN
+  SUBGOAL_THEN (``1 - (RE z / modu z) pow 2 = (IM z / modu z) pow 2 ``) ASSUME_TAC THENL
+  [REWRITE_TAC[REAL_EQ_SUB_RADD, REAL_POW_DIV, REAL_DIV_ADD] THEN
+  ONCE_REWRITE_TAC[REAL_ADD_COMM] THEN
+  REWRITE_TAC[GSYM MODU_POW2] THEN CONV_TAC SYM_CONV THEN
+  MATCH_MP_TAC REAL_DIV_REFL THEN
+  ASM_REWRITE_TAC[MODU_POW2, GSYM COMPLEX_0_THM],
+  ASM_REWRITE_TAC[] THEN MATCH_MP_TAC POW_2_SQRT THEN
+  MATCH_MP_TAC REAL_LE_DIV THEN ASM_REWRITE_TAC[MODU_POS]
+  ]
+  ],
+  REWRITE_TAC[SIN_PERIODIC,SIN_NEG, REAL_NEG_EQ] THEN
+  SUBGOAL_THEN (``sin (acs (RE z / modu z)) = sqrt (1 - cos (acs (RE z / modu z)) pow 2) ``) ASSUME_TAC THENL
+  [MATCH_MP_TAC SIN_COS_SQ THEN
+  MATCH_MP_TAC RE_DIV_MODU_ACS_BOUNDS THEN
+  ASM_REWRITE_TAC[],
+  ASM_REWRITE_TAC[] THEN
+  FIRST_ASSUM (fn th => REWRITE_TAC [MATCH_MP RE_DIV_MODU_ACS_COS th]) THEN
+  SUBGOAL_THEN (``1 - (RE z / modu z) pow 2 = (IM z / modu z) pow 2 ``) ASSUME_TAC THENL
+  [REWRITE_TAC[REAL_EQ_SUB_RADD, REAL_POW_DIV, REAL_DIV_ADD] THEN
+  ONCE_REWRITE_TAC[REAL_ADD_COMM] THEN
+  REWRITE_TAC[GSYM MODU_POW2] THEN CONV_TAC SYM_CONV THEN
+  MATCH_MP_TAC REAL_DIV_REFL THEN
+  ASM_REWRITE_TAC[MODU_POW2, GSYM COMPLEX_0_THM],
+  ASM_REWRITE_TAC[] THEN
+  ONCE_REWRITE_TAC[GSYM REAL_POW2_ABS] THEN
+  ONCE_REWRITE_TAC[GSYM ABS_NEG] THEN
+  REWRITE_TAC[REAL_POW2_ABS] THEN
+  MATCH_MP_TAC POW_2_SQRT THEN
+  REWRITE_TAC[real_div, REAL_NEG_LMUL] THEN
+  REWRITE_TAC[GSYM real_div] THEN
+  MATCH_MP_TAC REAL_LE_DIV THEN
+  PROVE_TAC [MODU_POS, REAL_NOT_LE, REAL_NEG_GT0, REAL_LT_IMP_LE]
+  ]
+  ]
+  ]);
+
+val RE_MODU_ARG = store_thm("RE_MODU_ARG",
+  ``!z:complex. RE z = modu z * cos (arg z)``,
+  GEN_TAC THEN ASM_CASES_TAC (``z = 0``) THENL
+  [ASM_REWRITE_TAC[MODU_0] THEN
+  REWRITE_TAC[complex_of_num,complex_of_real,RE,REAL_MUL_LZERO],
+  FIRST_ASSUM (fn th => REWRITE_TAC [MATCH_MP ARG_COS th]) THEN
+  CONV_TAC SYM_CONV THEN
+  MATCH_MP_TAC  REAL_DIV_LMUL THEN
+  ASM_REWRITE_TAC[GSYM MODU_ZERO]
+  ]);
+
+val IM_MODU_ARG = store_thm("IM_MODU_ARG",
+  ``!z:complex. IM z = modu z * sin (arg z)``,
+  GEN_TAC THEN ASM_CASES_TAC (``z = 0``) THENL
+  [ASM_REWRITE_TAC[MODU_0] THEN
+  REWRITE_TAC[complex_of_num,complex_of_real,IM,REAL_MUL_LZERO],
+  FIRST_ASSUM (fn th => REWRITE_TAC [MATCH_MP ARG_SIN th]) THEN
+  CONV_TAC SYM_CONV THEN
+  MATCH_MP_TAC  REAL_DIV_LMUL THEN
+  ASM_REWRITE_TAC[GSYM MODU_ZERO]
+  ]);
+
+val COMPLEX_TRIANGLE = store_thm("COMPLEX_TRIANGLE",
+  ``!z:complex. modu z * (cos (arg z),sin (arg z)) = z``,
+  REWRITE_TAC[complex_scalar_lmul, RE, IM, GSYM RE_MODU_ARG, GSYM IM_MODU_ARG]);
+
+val COMPLEX_MODU_ARG_EQ = store_thm("COMPLEX_MODU_ARG_EQ",
+  ``!z:complex w. (z = w) = ((modu z = modu w) /\ (arg z = arg w))``,
+  REPEAT GEN_TAC THEN EQ_TAC THEN DISCH_TAC THEN
+  ASM_REWRITE_TAC[COMPLEX_RE_IM_EQ,RE_MODU_ARG,IM_MODU_ARG]);
+
+val MODU_UNIT = store_thm("MODU_UNIT",
+  ``!x:real y. modu (cos x,sin x) = 1``,
+  REWRITE_TAC [modu, RE, IM] THEN ONCE_REWRITE_TAC[REAL_ADD_COMM]
+  THEN REWRITE_TAC[SIN_CIRCLE, SQRT_1]);
+
+val COMPLEX_MUL_ARG = store_thm("COMPLEX_MUL_ARG",
+  ``!x:real y:real.
+         (cos x,sin x) * (cos y, sin y) = (cos (x + y),sin (x + y))``,
+  REWRITE_TAC [complex_mul, RE, IM, SIN_ADD, COS_ADD] THEN
+  PROVE_TAC [REAL_ADD_COMM]);
+
+val COMPLEX_INV_ARG = store_thm("COMPLEX_INV_ARG",
+  ``!x:real. inv (cos x,sin x) = (cos (-x),sin (-x))``,
+  REWRITE_TAC [complex_inv, RE, IM] THEN
+  ONCE_REWRITE_TAC [REAL_ADD_COMM] THEN
+  REWRITE_TAC[SIN_CIRCLE, real_div, REAL_INV1,REAL_MUL_RID, COS_NEG, SIN_NEG]);
+
+val COMPLEX_DIV_ARG = store_thm("COMPLEX_DIV_ARG",
+  ``!x:real y.
+      (cos x,sin x) / (cos y, sin y) = (cos(x - y),sin(x - y))``,
+  REWRITE_TAC[complex_div,COMPLEX_INV_ARG,COMPLEX_MUL_ARG,real_sub]);
+
+(*--------------------------------------------------------------------*)
+(* The operation of nature numbers power of complex numbers           *)
+(*--------------------------------------------------------------------*)
+
+val complex_pow = Define
+`(complex_pow (z:complex) 0 = 1) /\
+      (complex_pow (z:complex) (SUC n) = z * (complex_pow z n))`;
+
+val _ = overload_on ("pow",  Term`$complex_pow`);
+
+val COMPLEX_POW_0 = store_thm("COMPLEX_POW_0",
+  ``!n:num. 0 pow (SUC n) = 0``,
+  INDUCT_TAC THEN REWRITE_TAC[complex_pow, COMPLEX_MUL_LZERO]);
+
+val COMPLEX_POW_NZ = store_thm("COMPLEX_POW_NZ",
+  ``!z:complex n:num. (z <> 0) ==> (z pow n <> 0)``,
+  REPEAT GEN_TAC THEN DISCH_TAC THEN
+  SPEC_TAC((``n:num``),(``n:num``)) THEN  INDUCT_TAC THEN
+  ASM_REWRITE_TAC[complex_pow, COMPLEX_10, COMPLEX_ENTIRE]);
+
+val COMPLEX_POWINV = store_thm("COMPLEX_POWINV",
+  ``!z:complex.
+         ~(z = 0) ==> !n:num. (inv(z pow n) = (inv z) pow n)``,
+  GEN_TAC THEN DISCH_TAC THEN INDUCT_TAC THEN
+  REWRITE_TAC[complex_pow, COMPLEX_INV1] THEN
+  MP_TAC(SPECL [(``z:complex``), (``z pow n``)] COMPLEX_INV_MUL) THEN
+  ASM_REWRITE_TAC[] THEN
+  SUBGOAL_THEN (``~(z pow n = 0)``) ASSUME_TAC THENL
+  [MATCH_MP_TAC COMPLEX_POW_NZ THEN ASM_REWRITE_TAC[], ALL_TAC]
+  THEN  ASM_REWRITE_TAC[]);
+
+val MODU_COMPLEX_POW = store_thm("MODU_COMPLEX_POW",
+  ``!z:complex n:num. modu (z pow n) = modu z pow n``,
+  GEN_TAC THEN INDUCT_TAC THEN
+  ASM_REWRITE_TAC[complex_pow,pow, MODU_1, MODU_MUL]);
+
+val COMPLEX_POW_ADD = store_thm("COMPLEX_POW_ADD",
+  ``!z:complex m:num n. z pow (m + n) = (z pow m) * (z pow n)``,
+  GEN_TAC THEN GEN_TAC THEN INDUCT_TAC THEN
+  ASM_REWRITE_TAC[complex_pow, ADD_CLAUSES, COMPLEX_MUL_RID] THEN
+  CONV_TAC(AC_CONV(COMPLEX_MUL_ASSOC,COMPLEX_MUL_COMM)));
+
+val COMPLEX_POW_1 = store_thm("COMPLEX_POW_1",
+  ``!z:complex. z pow 1 = z``,
+  GEN_TAC THEN REWRITE_TAC[num_CONV (``1:num``)] THEN
+  REWRITE_TAC[complex_pow, COMPLEX_MUL_RID]);
+
+val COMPLEX_POW_2 = store_thm("COMPLEX_POW_2",
+  ``!z:complex. z pow 2 = z * z``,
+  GEN_TAC THEN REWRITE_TAC[num_CONV ``2:num``] THEN
+  REWRITE_TAC[complex_pow, COMPLEX_POW_1]);
+
+val COMPLEX_POW_ONE = store_thm("COMPLEX_POW_ONE",
+  ``!n:num. 1 pow n = 1``,
+  INDUCT_TAC THEN ASM_REWRITE_TAC[complex_pow, COMPLEX_MUL_LID]);
+
+val COMPLEX_POW_MUL = store_thm("COMPLEX_POW_MUL",
+  ``!n:num z:complex w:complex. (z * w) pow n = (z pow n) * (w pow n)``,
+  INDUCT_TAC THEN REWRITE_TAC[complex_pow, COMPLEX_MUL_LID] THEN
+  REPEAT GEN_TAC THEN ASM_REWRITE_TAC[] THEN
+  CONV_TAC(AC_CONV(COMPLEX_MUL_ASSOC,COMPLEX_MUL_COMM)));
+
+val COMPLEX_POW_INV = store_thm("COMPLEX_POW_INV",
+  ``!z:complex n:num. (inv z) pow n = inv (z pow n)``,
+  Induct_on `n` THEN REWRITE_TAC [complex_pow] THENL
+  [REWRITE_TAC [COMPLEX_INV1],
+   GEN_TAC THEN Cases_on `z = 0` THENL
+   [POP_ASSUM SUBST_ALL_TAC
+     THEN REWRITE_TAC [COMPLEX_INV_0,COMPLEX_MUL_LZERO],
+    `~(z pow n = 0)` by PROVE_TAC [COMPLEX_POW_NZ] THEN
+    IMP_RES_TAC COMPLEX_INV_MUL THEN ASM_REWRITE_TAC []]]);
+
+val COMPLEX_POW_DIV = store_thm("COMPLEX_POW_DIV",
+  ``!z:complex w:complex n:num. (z / w) pow n = (z pow n) / (w pow n)``,
+  REWRITE_TAC[complex_div, COMPLEX_POW_MUL, COMPLEX_POW_INV]);
+
+val COMPLEX_POW_SCALAR_LMUL = store_thm("COMPLEX_POW_L",
+  ``!n:num k:real z:complex. (k * z) pow n = (k pow n) * (z pow n)``,
+  INDUCT_TAC THEN
+  REWRITE_TAC[complex_pow, pow, COMPLEX_SCALAR_LMUL_ONE] THEN
+  REPEAT GEN_TAC THEN ASM_REWRITE_TAC[] THEN
+  REWRITE_TAC[COMPLEX_MUL_SCALAR_LMUL2]);
+
+val COMPLEX_POW_ZERO = store_thm("COMPLEX_POW_ZERO",
+  ``!n:num z:complex. (z pow n = 0) ==> (z = 0)``,
+  INDUCT_TAC THEN GEN_TAC THEN REWRITE_TAC[complex_pow] THEN
+  REWRITE_TAC[COMPLEX_10, COMPLEX_ENTIRE] THEN
+  DISCH_THEN(DISJ_CASES_THEN2 ACCEPT_TAC ASSUME_TAC) THEN
+  FIRST_ASSUM MATCH_MP_TAC THEN FIRST_ASSUM ACCEPT_TAC);
+
+val COMPLEX_POW_ZERO_EQ = store_thm("COMPLEX_POW_ZERO_EQ",
+  ``!n:num z:complex. (z pow (SUC n) = 0) = (z = 0)``,
+  REPEAT GEN_TAC THEN EQ_TAC THEN
+  REWRITE_TAC[COMPLEX_POW_ZERO] THEN
+  DISCH_THEN SUBST1_TAC THEN REWRITE_TAC[COMPLEX_POW_0]);
+
+val COMPLEX_POW_POW = store_thm("COMPLEX_POW_POW",
+  ``!z:complex m:num n:num. (z pow m) pow n = z pow (m * n)``,
+  GEN_TAC THEN GEN_TAC THEN INDUCT_TAC THEN
+  ASM_REWRITE_TAC[complex_pow, MULT_CLAUSES, COMPLEX_POW_ADD]);
+
+val DE_MOIVRE_LEMMA = store_thm("DE_MOIVRE_LEMMA",
+  ``!x:real n:num. (cos x, sin x) pow n = (cos (&n * x), sin(&n * x))``,
+  GEN_TAC THEN INDUCT_TAC THEN ASM_REWRITE_TAC [complex_pow, REAL_MUL_LZERO, COS_0, SIN_0, complex_of_num, complex_of_real, COMPLEX_MUL_ARG] THEN ONCE_REWRITE_TAC [REAL_ADD_COMM] THEN REWRITE_TAC[REAL, REAL_ADD_RDISTRIB, REAL_MUL_LID]);
+
+val DE_MOIVRE_THM = store_thm("DE_MOIVRE_THM",
+  ``!z:complex n:num.
+     (modu z * (cos (arg z),sin (arg z))) pow n =
+          modu z pow n * (cos (&n * arg z),sin(&n * arg z))``,
+  REWRITE_TAC[COMPLEX_POW_SCALAR_LMUL, DE_MOIVRE_LEMMA]);
+
+(*--------------------------------------------------------------------*)
+(*Exponential form of complex numbers                                 *)
+(*--------------------------------------------------------------------*)
+
+val complex_exp = new_definition("complex_exp",
+  ``complex_exp (z:complex) = exp(RE z) * (cos (IM z),sin (IM z))``);
+
+val _ = overload_on ("exp",  Term`$complex_exp`);
+
+val EXP_IMAGINARY = store_thm("EXP_IMAGINARY",
+  ``!x:real. exp (i * x) = (cos x,sin x)``,
+  REWRITE_TAC[complex_exp, i, complex_scalar_rmul, RE, IM, REAL_MUL_LZERO, REAL_MUL_LID, EXP_0, COMPLEX_SCALAR_LMUL_ONE]);
+
+val EULER_FORMULE = store_thm("EULER_FORMULE",
+  ``!z:complex. modu z * exp (i * arg z) = z``,
+  REWRITE_TAC[complex_exp, i, complex_scalar_rmul, RE, IM, REAL_MUL_LZERO, REAL_MUL_LID, EXP_0, COMPLEX_SCALAR_LMUL_ONE, COMPLEX_TRIANGLE]);
+
+val COMPLEX_EXP_ADD = store_thm("COMPLEX_EXP_ADD",
+  ``!z:complex w:complex. exp (z + w) = exp z * exp w``,
+  REWRITE_TAC[complex_exp, COMPLEX_MUL_SCALAR_LMUL2, GSYM EXP_ADD, COMPLEX_MUL_ARG, complex_add, RE, IM]);
+
+val COMPLEX_EXP_NEG = store_thm("COMPLEX_EXP_NEG",
+  ``!z:complex. exp (-z) = inv (exp z)``,
+  GEN_TAC THEN
+  REWRITE_TAC [complex_exp, complex_neg, RE, IM, EXP_NEG, GSYM COMPLEX_INV_ARG] THEN
+  CONV_TAC SYM_CONV THEN MATCH_MP_TAC COMPLEX_INV_SCALAR_LMUL THEN
+  REWRITE_TAC[EXP_NZ, MODU_NZ, MODU_UNIT, REAL_LT_01]);
+
+val COMPLEX_EXP_SUB = store_thm("COMPLEX_EXP_SUB",
+  ``!z:complex w:complex. exp (z - w) = exp z / exp w``,
+  REWRITE_TAC[complex_sub,COMPLEX_EXP_ADD,COMPLEX_EXP_NEG,complex_div]);
+
+val COMPLEX_EXP_N = store_thm("COMPLEX_EXP_N",
+  ``!z:complex n:num. exp (&n * z) = exp z pow n``,
+  REWRITE_TAC[complex_scalar_lmul] THEN
+  REWRITE_TAC[complex_exp, RE, IM, EXP_N, GSYM DE_MOIVRE_LEMMA, COMPLEX_POW_SCALAR_LMUL]);
+
+val COMPLEX_EXP_0 = store_thm("COMPLEX_EXP_0",
+  ``exp 0 = 1``,
+  REWRITE_TAC[complex_of_num, complex_of_real, complex_exp, RE, IM, EXP_0, COS_0, SIN_0, COMPLEX_SCALAR_LMUL_ONE]);
+
+val COMPLEX_EXP_NZ = store_thm("COMPLEX_EXP_NZ",
+  ``!z:complex. exp z <> 0``,
+  REWRITE_TAC[complex_exp, COMPLEX_SCALAR_LMUL_ENTIRE] THEN
+  REWRITE_TAC[EXP_NZ, MODU_NZ, MODU_UNIT, REAL_LT_01]);
+
+val COMPLEX_EXP_ADD_MUL = store_thm("COMPLEX_EXP_ADD_MUL",
+  ``!z:complex w:complex. exp (z + w) * exp (-z) = exp w``,
+  REWRITE_TAC[GSYM COMPLEX_EXP_ADD, GSYM complex_sub, COMPLEX_ADD_SUB]);
+
+val COMPLEX_EXP_NEG_MUL = store_thm("COMPLEX_EXP_NEG_MUL",
+  ``!z:complex. exp z * exp (-z) = 1``,
+  REWRITE_TAC[GSYM COMPLEX_EXP_ADD, COMPLEX_ADD_RINV, COMPLEX_EXP_0]);
+
+val COMPLEX_EXP_NEG_MUL2 = store_thm("COMPLEX_EXP_NEG_MUL2",
+ ``!z:complex. exp (-z) * exp z = 1``,
+  ONCE_REWRITE_TAC[COMPLEX_MUL_COMM] THEN
+  MATCH_ACCEPT_TAC COMPLEX_EXP_NEG_MUL);
+
+val _ = export_theory()


Property changes on: HOL/src/complex/complexScript.sml
___________________________________________________________________
Added: svn:mime-type
   + text/plain
Added: svn:eol-style
   + native

Modified: HOL/tools/build-sequence
===================================================================
--- HOL/tools/build-sequence	2011-04-26 17:50:50 UTC (rev 9029)
+++ HOL/tools/build-sequence	2011-04-27 04:01:24 UTC (rev 9030)
@@ -115,6 +115,7 @@
 !src/quotient/examples/sigma
 src/rational
 src/real
+src/complex
 !!examples/separationLogic/src/
 src/HolQbf
 src/HolSmt


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 9038
          http://hol.svn.sourceforge.net/hol/?rev=9038&view=rev
Author:   michaeln
Date:     2011-05-02 01:44:26 +0000 (Mon, 02 May 2011)

Log Message:
-----------
A new theorem for complexScript, and a description in the release notes.

Thanks to Liming Li for these.

Modified Paths:
--------------
    HOL/doc/kananaskis-7.release.html
    HOL/src/complex/complexScript.sml

Modified: HOL/doc/kananaskis-7.release.html
===================================================================
--- HOL/doc/kananaskis-7.release.html	2011-05-01 11:55:55 UTC (rev 9037)
+++ HOL/doc/kananaskis-7.release.html	2011-05-02 01:44:26 UTC (rev 9038)
@@ -72,6 +72,12 @@
 function <code>rpow</code>.  (The existing function <code>pow</code>
 requires a natural number as the exponent.)  Thanks to Umair Siddique
 for the definition and theorems.
+
+
+<li><p>
+A formalisation of the complex numbers by Yong Guan, Liming Li, Minhua Wu and Zhiping Shi.
+The authors referred to the HOL Light theory by John Harrison and the theory in PVS.
+It includes treatments of the complex numbers in the real pair form, the polar form and the exponential form, with basic arithmetic results and some other theorems.
 </ul>
 
 <h2 id="new-tools">New tools:</h2>

Modified: HOL/src/complex/complexScript.sml
===================================================================
--- HOL/src/complex/complexScript.sml	2011-05-01 11:55:55 UTC (rev 9037)
+++ HOL/src/complex/complexScript.sml	2011-05-02 01:44:26 UTC (rev 9038)
@@ -1455,6 +1455,12 @@
   REWRITE_TAC[complex_exp, RE, IM, EXP_N, GSYM DE_MOIVRE_LEMMA,
               COMPLEX_POW_SCALAR_LMUL]);
 
+val COMPLEX_EXP_N2 = store_thm("COMPLEX_EXP_N2",
+  ``!z:complex n:num. exp (&n :complex * z) = exp z pow n``,
+  REWRITE_TAC[complex_mul, complex_of_num, RE_COMPLEX_OF_REAL,
+              IM_COMPLEX_OF_REAL, REAL_MUL_LZERO, REAL_ADD_RID,REAL_SUB_RZERO,
+              GSYM complex_scalar_lmul, COMPLEX_EXP_N]);
+
 val COMPLEX_EXP_0 = store_thm("COMPLEX_EXP_0",
   ``exp 0c = 1``,
   REWRITE_TAC[complex_of_num, complex_of_real, complex_exp, RE, IM, EXP_0,


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 9086
          http://hol.svn.sourceforge.net/hol/?rev=9086&view=rev
Author:   michaeln
Date:     2011-05-31 06:32:38 +0000 (Tue, 31 May 2011)

Log Message:
-----------
Bug-fix: exported xTheory.sig files could contain spurious 'comments'.

In particular, if a comment-string (i.e., (* or *)) appeared as part
of a string literal in an exported theorem, this caused the resulting
Theory.sig file to be malformed SML.  The fix was to create a trace
variable allowing string-literal printing to become more 'paranoid'
when done in the TheoryPP code.  In that context, occurrences of the
bad strings have their asterisks replaced by \042, which is correct
SML/HOL notation for ASCII character 42, which is the asterisk.

Note that this problem doesn't arise in normal interactive use: the
HOL lexer doesn't get confused by comment strings in string literals,
and the SML level thinks all of the content in a quotation is inside
one of its own string literals.

Include a comment in the Description manual about not using tokens
that include comment strings or whitespace.

Thanks to Magnus for the bug report.

Modified Paths:
--------------
    HOL/Manual/Description/system.tex
    HOL/src/parse/Literal.sig
    HOL/src/parse/Literal.sml
    HOL/src/parse/Parse.sml
    HOL/src/parse/term_pp.sml
    HOL/src/string/selftest.sml
    HOL/tools/build-sequence

Added Paths:
-----------
    HOL/src/string/theorytesting/
    HOL/src/string/theorytesting/otherScript.sml
    HOL/src/string/theorytesting/sampleScript.sml

Modified: HOL/Manual/Description/system.tex
===================================================================
--- HOL/Manual/Description/system.tex	2011-05-31 06:31:46 UTC (rev 9085)
+++ HOL/Manual/Description/system.tex	2011-05-31 06:32:38 UTC (rev 9086)
@@ -156,6 +156,13 @@
    'a   'b   'cat   'A11   'g_a_p   'f'oo
 \end{verbatim}
 \end{hol}
+
+\paragraph{User tokens}
+In general, a \HOL{} user has a great deal of freedom to create their own syntax, involving special tokens quite apart from variables and names for constants.
+For example, the if-then-else syntax for the conditional operator %
+\index{conditionals, in HOL logic@..., in \HOL{} logic!printing of}%
+has special tokens (the ``if'', ``then'' and ``else'') that are not names for variables, nor constants (the underlying constant is actually called \holtxt{COND}).
+In order to make sure that the operations of printing and parsing tokens are suitably inverse to each other, users should not create tokens that include whitespace, or the comment strings (\ml{(*} and \ml{*)}).
 \index{tokens|)}
 
 \section{Types}\index{types, in HOL logic@..., in \HOL{} logic}

Modified: HOL/src/parse/Literal.sig
===================================================================
--- HOL/src/parse/Literal.sig	2011-05-31 06:31:46 UTC (rev 9085)
+++ HOL/src/parse/Literal.sig	2011-05-31 06:32:38 UTC (rev 9086)
@@ -19,6 +19,7 @@
  val mk_string_lit   : {mk_string   : 'a * 'a -> 'a,
                         emptystring : 'a,
                         fromMLchar  : char -> 'a} -> String.string -> 'a
+ val string_literalpp: string -> string
 
  val is_char_lit     : term -> bool
  val dest_char_lit   : term -> Char.char

Modified: HOL/src/parse/Literal.sml
===================================================================
--- HOL/src/parse/Literal.sml	2011-05-31 06:31:46 UTC (rev 9085)
+++ HOL/src/parse/Literal.sml	2011-05-31 06:32:38 UTC (rev 9086)
@@ -161,6 +161,38 @@
 
 val is_string_lit = can dest_string_lit
 
+val paranoid_stringlitpp = ref false
+val _ = Feedback.register_btrace
+            ("paranoid string literal printing", paranoid_stringlitpp)
+fun string_literalpp s =
+    if not (!paranoid_stringlitpp) then Lib.mlquote s
+    else let
+        val limit = size s
+        fun sub i = String.sub(s,i)
+        fun extract(i,c) = String.extract(s,i,c)
+        val concat = String.concat
+        val toString = String.toString
+        fun recurse A lastc start i =
+            if i >= limit then concat (List.rev("\"" :: extract(start,NONE)::A))
+            else
+              case (lastc, sub i) of
+                (#"(", #"*") => let
+                  val p = toString (extract(start,SOME (i - start - 1))) ^ "(\\042"
+                in
+                  recurse (p::A) #" " (i + 1) (i + 1)
+                end
+              | (#"*", #")") => let
+                  val p = toString (extract(start,SOME(i - start - 1))) ^ "\\042)"
+                in
+                  recurse (p::A) #" " (i + 1) (i + 1)
+                end
+              | (_, c) => recurse A c start (i + 1)
+      in
+        recurse ["\""] #" " 0 0
+      end
+
+
+
 (*---------------------------------------------------------------------------*)
 (* Redefine dest_string_lit to handle cases where c in CHR (c) is either a   *)
 (* "bare" numeral or of the form (NUMERAL ...). Used in ML generation.       *)

Modified: HOL/src/parse/Parse.sml
===================================================================
--- HOL/src/parse/Parse.sml	2011-05-31 06:31:46 UTC (rev 9085)
+++ HOL/src/parse/Parse.sml	2011-05-31 06:32:38 UTC (rev 9086)
@@ -1516,9 +1516,9 @@
 end
 
 val _ = let
-  fun rawpp_thm pps th =
-      Lib.with_flag (current_backend, PPBackEnd.raw_terminal)
-                    (pp_thm pps) th
+  fun rawpp_thm pps =
+      pp_thm pps |> Lib.with_flag (current_backend, PPBackEnd.raw_terminal)
+                 |> trace ("paranoid string literal printing", 1)
 in
   Theory.pp_thm := rawpp_thm
 end

Modified: HOL/src/parse/term_pp.sml
===================================================================
--- HOL/src/parse/term_pp.sml	2011-05-31 06:31:46 UTC (rev 9085)
+++ HOL/src/parse/term_pp.sml	2011-05-31 06:32:38 UTC (rev 9086)
@@ -1785,7 +1785,7 @@
           (* strings *)
           (case total Literal.dest_string_lit tm of
              NONE => fail
-           | SOME s => add_string (Lib.mlquote s)) |||
+           | SOME s => add_string (Literal.string_literalpp s)) |||
 
           (* characters *)
           (fn _ => case total Literal.dest_char_lit tm of

Modified: HOL/src/string/selftest.sml
===================================================================
--- HOL/src/string/selftest.sml	2011-05-31 06:31:46 UTC (rev 9085)
+++ HOL/src/string/selftest.sml	2011-05-31 06:32:38 UTC (rev 9086)
@@ -96,9 +96,18 @@
 val _ = app tpp ["P \"a\" /\\ Q",
                  "P (STRCAT a \"b\") /\\ Q",
                  "#\"a\"",
-                 "\"(*\""]
+                 "\"(*\"",
+                 "\"*)\""]
 
+val _ = set_trace "paranoid string literal printing" 1
 
+val t = ``"*)"``
+val _ = tprint "Paranoid printing of ``\"*)\"``"
+val s = term_to_string t
+val _ = if s = "\"\\042)\"" then print "OK\n"
+        else (print "FAILED!\n"; Process.exit Process.failure)
+
+
 val _ = OS.Process.exit OS.Process.success
 
 

Added: HOL/src/string/theorytesting/otherScript.sml
===================================================================
--- HOL/src/string/theorytesting/otherScript.sml	                        (rev 0)
+++ HOL/src/string/theorytesting/otherScript.sml	2011-05-31 06:32:38 UTC (rev 9086)
@@ -0,0 +1,14 @@
+
+
+open HolKernel Parse boolLib bossLib;
+
+val _ = new_theory "other";
+
+
+open sampleTheory;
+
+val _ = print "Successfully opened sampleTheory\n"
+
+
+val _ = export_theory();
+


Property changes on: HOL/src/string/theorytesting/otherScript.sml
___________________________________________________________________
Added: svn:mime-type
   + text/plain
Added: svn:eol-style
   + native

Added: HOL/src/string/theorytesting/sampleScript.sml
===================================================================
--- HOL/src/string/theorytesting/sampleScript.sml	                        (rev 0)
+++ HOL/src/string/theorytesting/sampleScript.sml	2011-05-31 06:32:38 UTC (rev 9086)
@@ -0,0 +1,9 @@
+
+open HolKernel Parse boolLib bossLib stringTheory;
+val _ = new_theory "sample";
+
+val _ = Define `badstring = "*)"`;
+
+(* val _ = max_print_depth := 0; *)
+val _ = export_theory();
+


Property changes on: HOL/src/string/theorytesting/sampleScript.sml
___________________________________________________________________
Added: svn:mime-type
   + text/plain
Added: svn:eol-style
   + native

Modified: HOL/tools/build-sequence
===================================================================
--- HOL/tools/build-sequence	2011-05-31 06:31:46 UTC (rev 9085)
+++ HOL/tools/build-sequence	2011-05-31 06:32:38 UTC (rev 9086)
@@ -94,6 +94,7 @@
 !examples/RSA
 src/sort
 src/string
+!src/string/theorytesting
 !examples/STE
 src/res_quan/src
 src/quotient/src


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 9096
          http://hol.svn.sourceforge.net/hol/?rev=9096&view=rev
Author:   michaeln
Date:     2011-06-02 05:24:21 +0000 (Thu, 02 Jun 2011)

Log Message:
-----------
Move bvk_find_term (used in DEEP_INTROk_TAC) to HolKernel.

Document it and the other find_term functions from HolKernel.

Modified Paths:
--------------
    HOL/src/1/Tactic.sml
    HOL/src/postkernel/HolKernel.sml

Added Paths:
-----------
    HOL/help/Docfiles/HolKernel.bvk_find_term.doc
    HOL/help/Docfiles/HolKernel.find_term.doc
    HOL/help/Docfiles/HolKernel.find_terms.doc

Added: HOL/help/Docfiles/HolKernel.bvk_find_term.doc
===================================================================
--- HOL/help/Docfiles/HolKernel.bvk_find_term.doc	                        (rev 0)
+++ HOL/help/Docfiles/HolKernel.bvk_find_term.doc	2011-06-02 05:24:21 UTC (rev 9096)
@@ -0,0 +1,57 @@
+\DOC
+
+\TYPE {bvk_find_term : (term list * term -> bool) -> (term -> 'a) -> term -> 'a option}
+
+\SYNOPSIS
+Finds a sub-term satisfying predicate argument; applies a continuation.
+
+\KEYWORDS
+Term.
+
+\DESCRIBE
+A call to {bvk_find_term P k tm} searches {tm} for a sub-term
+satisfying {P} and calls the continuation {k} on the first that it
+finds.  If {k} succeeds on this sub-term, the result is wrapped in
+{SOME} and returned to the caller.  If {k} raises a {HOL_ERR}
+exception on the sub-term, control returns to {bvk_find_term}, which
+continues to look for a sub-term satisfying {P}.  Other exceptions are
+returned to the caller. If there is no sub-term that both satisfies
+{P} and on which {k} operates successfully, the result is {NONE}.
+
+The search order is top-down, left-to-right (i.e., rators of combs are
+examined before rands).
+
+As with {find_term}, {P} should be total.  In addition, {P} is given
+not just the sub-term of interest, but also the stack of bound
+variables that have scope over the sub-term, with the innermost bound
+variables appearing earlier in the list.
+
+\FAILURE
+Fails if the predicate argument fails (i.e., raises an exception; returning false is acceptable) on a sub-term, or if the contination argument raises a non-{HOL_ERR} exception on a sub-term on which the predicate has returned true.
+
+\EXAMPLE
+The {RED_CONV} function from {reduceLib} reduces a ground arithmetic
+term over the natural numbers, failing if the term is not of the right
+shape.
+{
+   - val find = bvk_find_term (equal ``:num`` o type_of o #2)
+                              reduceLib.RED_CONV;
+   > val find = fn : term -> thm option
+
+   - find ``SUC n``;
+   > val it = NONE : thm option
+
+   - find ``2 * 3 + SUC n``;
+   > val it = SOME |- 2 * 3 = 6 : thm option
+
+   - find ``SUC n + 2 * 3``;
+   > val it = SOME |- 2 * 3 = 6 : thm option
+
+   - find ``2 + 1 + SUC n + 2 * 3``;
+   > val it = SOME |- 2 + 1 = 3 : thm option
+}
+
+\SEEALSO
+HolKernel.find_term, HolKernel.find_terms.
+
+\ENDDOC


Property changes on: HOL/help/Docfiles/HolKernel.bvk_find_term.doc
___________________________________________________________________
Added: svn:mime-type
   + text/plain
Added: svn:eol-style
   + native

Added: HOL/help/Docfiles/HolKernel.find_term.doc
===================================================================
--- HOL/help/Docfiles/HolKernel.find_term.doc	                        (rev 0)
+++ HOL/help/Docfiles/HolKernel.find_term.doc	2011-06-02 05:24:21 UTC (rev 9096)
@@ -0,0 +1,32 @@
+\DOC
+
+\TYPE {find_term : (term -> bool) -> term -> term}
+
+\SYNOPSIS
+Finds a sub-term satisfying a predicate.
+
+\KEYWORDS
+Term.
+
+\DESCRIBE
+A call to {find_term P t} returns a sub-term of {t} that satisfies the
+predicate {P} if there is one.  Otherwise it raises a {HOL_ERR}
+exception.  The search is done in a top-down, left-to-right order
+(i.e., rators of combs are examined before rands).
+
+\FAILURE
+Fails if the predicate fails when applied to any of the sub-terms of the term argument.  Also fails if there is no sub-term satisfying the predicate.
+
+\EXAMPLE
+{
+- find_term Literal.is_numeral ``2 + x + 3``;
+> val it = ``2`` : term
+
+- find_term Literal.is_numeral ``x + y``;
+Exception HOL_ERR {...}
+}
+
+\SEEALSO
+HolKernel.bvk_find_term, HolKernel.find_terms.
+
+\ENDDOC


Property changes on: HOL/help/Docfiles/HolKernel.find_term.doc
___________________________________________________________________
Added: svn:mime-type
   + text/plain
Added: svn:eol-style
   + native

Added: HOL/help/Docfiles/HolKernel.find_terms.doc
===================================================================
--- HOL/help/Docfiles/HolKernel.find_terms.doc	                        (rev 0)
+++ HOL/help/Docfiles/HolKernel.find_terms.doc	2011-06-02 05:24:21 UTC (rev 9096)
@@ -0,0 +1,36 @@
+\DOC
+
+\TYPE {find_terms : (term -> bool) -> term -> term list}
+
+\SYNOPSIS
+Traverses a term, returning a list of sub-terms satisfying a predicate.
+
+\KEYWORDS
+Term.
+
+\DESCRIBE
+A call to {find_terms P t} returns a list of sub-terms of {t} that
+satisfy {P}.  The resulting list is ordered as if the traversal had
+been bottom-up and right-to-left (i.e., the rands of combs visited
+before their rators).  The term {t} is itself considered a possible
+sub-term of {t}.
+
+\FAILURE
+Only fails if the predicate fails on one of the term's sub-terms.
+
+\EXAMPLE
+{
+- find_terms (fn _ => true) ``x + y``;
+> val it = [``y``, ``x``, ``$+``, ``$+ x``, ``x + y``]
+
+- find_terms Literal.is_numeral ``x + y``;
+> val it = [] : term list
+
+- find_terms Literal.is_numeral ``1 + x + 2 + y``;
+> val it = [``2``, ``1``] : term list
+}
+
+\SEEALSO
+HolKernel.bvk_find_term, HolKernel.find_term.
+
+\ENDDOC


Property changes on: HOL/help/Docfiles/HolKernel.find_terms.doc
___________________________________________________________________
Added: svn:mime-type
   + text/plain
Added: svn:eol-style
   + native

Modified: HOL/src/1/Tactic.sml
===================================================================
--- HOL/src/1/Tactic.sml	2011-06-02 05:23:35 UTC (rev 9095)
+++ HOL/src/1/Tactic.sml	2011-06-02 05:24:21 UTC (rev 9096)
@@ -912,36 +912,6 @@
   INST (HOLset.foldl foldthis [] true_frees) th
 end
 
-(* Finds a sub-term satisfying P and applies k to it.  If this raises a HOL_ERR,
-   keeps going to find another sub-term.  P is given the stack of 'governing'
-   bound variables. Searches top-down and left-to-right. If nothing is found that
-   works, return NONE. *)
-datatype 'a exn_trap = OK of 'a | EXN of exn
-datatype action = SEARCH of term | POP
-fun trap f x = OK (f x) handle e => EXN e
-fun bvfind_term P k t = let
-  fun search bvs actions =
-      case actions of
-        [] => NONE
-      | POP :: alist => search (tl bvs) alist
-      | SEARCH t :: alist => let
-        in
-          if P (bvs, t) then
-            case trap k t of
-              OK result => SOME result
-            | EXN (HOL_ERR _) => subterm bvs alist t
-            | EXN e => raise e
-          else subterm bvs alist t
-        end
-  and subterm bvs alist t =
-      case dest_term t of
-        COMB(t1, t2) => search bvs (SEARCH t1 :: SEARCH t2 :: alist)
-      | LAMB(bv, t) => search (bv::bvs) (SEARCH t :: POP :: alist)
-      | _ => search bvs alist
-in
-  search [] [SEARCH t]
-end
-
 fun IMP2AND_CONV t =
     if is_imp t then
       (RAND_CONV IMP2AND_CONV THENC
@@ -975,7 +945,7 @@
       (CONV_TAC (UNBETA_CONV subt) THEN
        MATCH_MP_TAC th THEN BETA_TAC THEN tac) (asl, g)
 in
-  case bvfind_term test continuation g of
+  case bvk_find_term test continuation g of
     SOME result => result
   | NONE => raise ERR "DEEP_INTROk_TAC" "No matching sub-terms"
 end

Modified: HOL/src/postkernel/HolKernel.sml
===================================================================
--- HOL/src/postkernel/HolKernel.sml	2011-06-02 05:23:35 UTC (rev 9095)
+++ HOL/src/postkernel/HolKernel.sml	2011-06-02 05:24:21 UTC (rev 9096)
@@ -194,6 +194,54 @@
  in find_tm
  end;
 
+(* ----------------------------------------------------------------------
+    bvk_find_term :
+     (term list * term -> bool) -> (term -> 'a) -> term -> 'a option
+
+    [bvk_find_term P k tm] searches tm for a sub-term satisfying P and
+    calls the continuation k on the first that it finds.  If k
+    succeeds on this sub-term, the result is wrapped in SOME.  If k
+    raises a HOL_ERR exception, control returns to bvk_find_term,
+    which continues to look for a sub-term satisfying P.  Other
+    exceptions are returned to the caller. If there is no sub-term
+    that both satisfies P and which k operates on successfully, the
+    result is NONE.
+
+    The search order is top-down, left-to-right (i.e., rators of combs
+    are examined before rands).
+
+    As with find_term, P should be total.  In addition, P is given not
+    just the sub-term of interest, but also the stack of bound
+    variables that have scope over the sub-term, with the innermost
+    bound variables appearing earlier in the list.
+   ---------------------------------------------------------------------- *)
+
+local
+datatype action = SEARCH of term | POP
+in
+fun bvk_find_term P k t = let
+  fun search bvs actions =
+      case actions of
+        [] => NONE
+      | POP :: alist => search (tl bvs) alist
+      | SEARCH t :: alist => let
+        in
+          if P (bvs, t) then
+            SOME (k t) handle HOL_ERR _ => subterm bvs alist t
+          else subterm bvs alist t
+        end
+  and subterm bvs alist t =
+      case dest_term t of
+        COMB(t1, t2) => search bvs (SEARCH t1 :: SEARCH t2 :: alist)
+      | LAMB(bv, t) => search (bv::bvs) (SEARCH t :: POP :: alist)
+      | _ => search bvs alist
+in
+  search [] [SEARCH t]
+end
+end (* local *)
+
+
+
 (*---------------------------------------------------------------------------
  * find_terms: (term -> bool) -> term -> term list
  *


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 9117
          http://hol.svn.sourceforge.net/hol/?rev=9117&view=rev
Author:   michaeln
Date:     2011-06-12 12:26:01 +0000 (Sun, 12 Jun 2011)

Log Message:
-----------
Move a couple of useful theorems about 'some' into optionTheory.

Modified Paths:
--------------
    HOL/examples/lambda/basics/termScript.sml
    HOL/src/option/optionScript.sml

Modified: HOL/examples/lambda/basics/termScript.sml
===================================================================
--- HOL/examples/lambda/basics/termScript.sml	2011-06-12 07:27:00 UTC (rev 9116)
+++ HOL/examples/lambda/basics/termScript.sml	2011-06-12 12:26:01 UTC (rev 9117)
@@ -188,18 +188,6 @@
   EQ_TAC THEN SRW_TAC [][] THEN
   Q.SPEC_THEN `t` STRUCT_CASES_TAC term_CASES THEN SRW_TAC [][]);
 
-val some_F = store_thm(
-  "some_F",
-  ``(some x. F) = NONE``,
-  DEEP_INTRO_TAC optionTheory.some_intro THEN SRW_TAC [][]);
-val _ = export_rewrites ["some_F"]
-
-val some_EQ = store_thm(
-  "some_EQ",
-  ``((some x. x = y) = SOME y) ∧ ((some x. y = x) = SOME y)``,
-  CONJ_TAC THEN DEEP_INTRO_TAC optionTheory.some_intro THEN SRW_TAC [][]);
-val _ = export_rewrites ["some_EQ"]
-
 val some_PAIR_EQ = prove(
   ``(some (x,y). (x' = x) /\ (y' = y)) = SOME(x',y')``,
   DEEP_INTRO_TAC optionTheory.some_intro THEN

Modified: HOL/src/option/optionScript.sml
===================================================================
--- HOL/src/option/optionScript.sml	2011-06-12 07:27:00 UTC (rev 9116)
+++ HOL/src/option/optionScript.sml	2011-06-12 12:26:01 UTC (rev 9117)
@@ -463,7 +463,18 @@
   SRW_TAC [][some_def] THEN METIS_TAC []);
 val _ = set_fixity "some" Binder
 
+val some_F = store_thm(
+  "some_F",
+  ``(some x. F) = NONE``,
+  DEEP_INTRO_TAC some_intro THEN SRW_TAC [][]);
+val _ = export_rewrites ["some_F"]
 
+val some_EQ = store_thm(
+  "some_EQ",
+  ``((some x. x = y) = SOME y) /\ ((some x. y = x) = SOME y)``,
+  CONJ_TAC THEN DEEP_INTRO_TAC some_intro THEN SRW_TAC [][]);
+val _ = export_rewrites ["some_EQ"]
+
 val option_case_cong =
   save_thm("option_case_cong",
       Prim_rec.case_cong_thm option_nchotomy option_case_def);


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 9135
          http://hol.svn.sourceforge.net/hol/?rev=9135&view=rev
Author:   michaeln
Date:     2011-06-22 05:10:03 +0000 (Wed, 22 Jun 2011)

Log Message:
-----------
Rename TruePrefix to Prefix; use fixity options with NONE for what was Prefix.

90+% of this work was done by Ramana Kumar.  The following list are
the commits for a series of individual commits that have been squished
into one big change:
* remove mention of TruePrefix from the add_rule docfile
* first batch of changes removing TruePrefix from src/parse
* replace TruePrefix by Prefix in boolScript.sml
* remove TruePrefix from Rsyntax
  is a fixity ever required for new_specification?
* some more Prefix -> NONE and TruePrefix -> Prefix in theories
* TruePrefix changes for datatype
* TruePrefix changes for res_quan
* TruePrefix->Prefix in a TeX selftest
* TruePrefix changes for quotient
* TruePrefix changes for integer and real
* fix quotient examples for TruePrefix removal
* more fixes for quotient examples
* fixes for lambda example for TruePrefix removal
* Reword description manual in light of removal of TruePrefix.
* Fix msgTheory quotient example; Poly 5.3 had problems with monotypes.
* Fixes for files in examples/lambda given removal of TruePrefix.
* Fix in examples/unification given removal of TruePrefix.
* Fix in examples/HolCheck given removal of TruePrefix.
* Fixes in examples/acl2 given removal of TruePrefix.

Modified Paths:
--------------
    HOL/Manual/Description/libraries.tex
    HOL/examples/HolCheck/muSyntaxScript.sml
    HOL/examples/acl2/examples/M1/sexpScript.sml
    HOL/examples/acl2/examples/acl2-hol-ltl-paper-example/sexpScript.sml
    HOL/examples/acl2/examples/example_axiomsScript.ml
    HOL/examples/acl2/ml/make_sexp.ml
    HOL/examples/acl2/ml/sexpScript.sml
    HOL/examples/lambda/barendregt/labelledTermsScript.sml
    HOL/examples/lambda/basics/generic_termsScript.sml
    HOL/examples/lambda/basics/termScript.sml
    HOL/examples/lambda/examples/holScript.sml
    HOL/examples/lambda/typing/type_schemasScript.sml
    HOL/examples/unification/triangular/nominal/ntermScript.sml
    HOL/help/Docfiles/Parse.add_rule.doc
    HOL/src/1/Drule.sml
    HOL/src/1/Prim_rec.sml
    HOL/src/1/Rsyntax.sig
    HOL/src/1/Rsyntax.sml
    HOL/src/TeX/selftest.sml
    HOL/src/bool/boolScript.sml
    HOL/src/datatype/equiv/EquivType.sig
    HOL/src/datatype/equiv/EquivType.sml
    HOL/src/datatype/ind_typeScript.sml
    HOL/src/integer/integerScript.sml
    HOL/src/list/src/listScript.sml
    HOL/src/list/src/rich_listScript.sml
    HOL/src/num/theories/arithmeticScript.sml
    HOL/src/parse/Parse.sig
    HOL/src/parse/Parse.sml
    HOL/src/parse/ProvideUnicode.sml
    HOL/src/parse/term_grammar.sig
    HOL/src/parse/term_grammar.sml
    HOL/src/pred_set/src/pred_setScript.sml
    HOL/src/quotient/examples/ext_finite_setScript.sml
    HOL/src/quotient/examples/finite_setScript.sml
    HOL/src/quotient/examples/lambda/liftScript.sml
    HOL/src/quotient/examples/lambda/more_setScript.sml
    HOL/src/quotient/examples/lambda/variableScript.sml
    HOL/src/quotient/examples/msgScript.sml
    HOL/src/quotient/examples/sigma/liftScript.sml
    HOL/src/quotient/examples/sigma/more_setScript.sml
    HOL/src/quotient/examples/sigma/variableScript.sml
    HOL/src/quotient/src/quotient.sig
    HOL/src/quotient/src/quotient.sml
    HOL/src/quotient/src/selftest.sml
    HOL/src/real/hratScript.sml
    HOL/src/real/realaxScript.sml
    HOL/src/res_quan/src/res_quanTools.sml

Modified: HOL/Manual/Description/libraries.tex
===================================================================
--- HOL/Manual/Description/libraries.tex	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/Manual/Description/libraries.tex	2011-06-22 05:10:03 UTC (rev 9135)
@@ -686,19 +686,11 @@
 \subsubsection{Fixities}
 \label{sec:parseprint:fixities}
 
-In order to provide some notational flexibility, constants come in
-various flavours or {\it fixities}: besides being an ordinary constant
-(with a fixity of {\sf Prefix}), constants can also be {\it binders},
-{\it true prefixes}\footnote{The use of the term ``true prefix'' is
-forced upon us by the history of the system, which reserved the
-classification ``prefix'' for terms without any special syntactic
-features.}, {\it suffixes}, {\it infixes}, or {\it closefixes}.  More
-generally, terms can also be represented using reasonably arbitrary
-{\it mixfix} specifications.  The degree to which terms bind their
-associated arguments is known as precedence.  The higher this number,
-the tighter the binding.  For example, when introduced, \verb-+- has a
-precedence of 500, while the tighter binding multiplication (\verb+*+)
-has a precedence of 600.
+In order to provide some notational flexibility, constants come in various flavours or {\it fixities}: besides being an ordinary constant (with no fixity), constants can also be {\it binders}, {\it prefixes}, {\it suffixes}, {\it infixes}, or {\it closefixes}.
+More generally, terms can also be represented using reasonably arbitrary {\it mixfix} specifications.
+The degree to which terms bind their associated arguments is known as precedence.
+The higher this number, the tighter the binding.
+For example, when introduced, \verb-+- has a precedence of 500, while the tighter binding multiplication (\verb+*+) has a precedence of 600.
 
 \paragraph{Binders}
 
@@ -755,15 +747,16 @@
 ((\holtxt{<infix>}\; \term)\; \term)
 \]
 
-\paragraph{True prefixes}
+\paragraph{Prefixes}
 
-Where infixes appear between their arguments, true prefixes appear
-before theirs.  This might initially appear to be the same thing as
-happens with normal function application (is $f$ in $f(x)$ not acting
-as a prefix?), but in fact, it is useful to allow for prefixes to have
-binding power less than that associated with function application.  An
-example of this is \verb+~+, logical negation.  This is a prefix with
-lower precedence than function application.  Normally
+Where infixes appear between their arguments, prefixes appear before theirs.
+This might initially appear to be the same thing as happens with normal function application where the symbol on the left simply has no fixity: is $f$ in $f(x)$ not acting as a prefix?
+Actually though, in a term such as $f(x)$, where $f$ and $x$ do not have fixities, the syntax is treated as if there is an invisible infix function application between the two tokens: $f\cdot{}x$.
+This infix operator binds tightly, so that when one writes $f\,x + y$, the parse is $(f\cdot{}x) + y$.\footnote{There are tighter infix operators: the dot in field selection causes $f\,x.fld$ to parse as $f\cdot(x.fld)$.\index{record types!field selection notation}}
+It is then useful to allow for genuine prefixes so that operators can live at different precedence levels than function application.
+An example of this is \verb+~+, logical negation.
+This is a prefix with lower precedence than function application.
+Normally
 \[
    f\;x\; y\qquad \mbox{is parsed as}\qquad (f\; x)\; y
 \] but \[
@@ -775,13 +768,16 @@
   negop}\,{\it negop}\,3
 \] (whatever {\it negop} happened to be) without needing extra parentheses.
 
+On the other hand, the \holtxt{univ} syntax for the universal set (see Section~\ref{sec:theory-of-sets}\index{universal set}) is an example of a prefix operator that binds more tightly than application.
+This means that \holtxt{f\,univ(:'a)} is parsed as \holtxt{f(univ(:'a))}, not \holtxt{(f univ)(:'a)} (which parse would fail to type-check).
+
 \paragraph{Suffixes}
 
 Suffixes appear after their arguments.  There are no suffixes
 introduced into the standard theories available in \HOL{}, but users
 are always able to introduce their own if they choose.  Suffixes are
-associated with a precedence just as infixes and true prefixes are.
-If \holtxt{p} is a true prefix, \holtxt{i} an infix, and \holtxt{s} a
+associated with a precedence just as infixes and prefixes are.
+If \holtxt{p} is a prefix, \holtxt{i} an infix, and \holtxt{s} a
 suffix, then there are six possible orderings for the three different
 operators based on their precedences, giving five parses for
 $\holtxt{p}\; t_1\; \holtxt{i}\; t_2\; \holtxt{s}$ depending on the
@@ -865,12 +861,12 @@
   \]
 %
  Because there needs to be a ``dangling'' term to the right, the
-  appropriate fixity is \ml{TruePrefix}.  Knowing that the underlying
+  appropriate fixity is \ml{Prefix}.  Knowing that the underlying
   term constant is called \holtxt{COND}, the simplest way to achieve
   the desired syntax is:
 \begin{verbatim}
 val _ = add_rule
-   {term_name = "COND", fixity = TruePrefix 70,
+   {term_name = "COND", fixity = Prefix 70,
     pp_elements = [TOK "if", BreakSpace(1,0), TM, BreakSpace(1,0),
                    TOK "then", BreakSpace(1,0), TM, BreakSpace(1,0),
                    TOK "else", BreakSpace(1,0)],
@@ -888,7 +884,7 @@
 \]
 denoting the substitution of $t_1$ for $t_2$ in $t_3$, perhaps
 translating to \holtxt{SUB $t_1$ $t_2$ $t_3$}.  This looks
-like it should be another \ml{TruePrefix}, but the choice of the
+like it should be another \ml{Prefix}, but the choice of the
 square brackets (\holtxt{[} and \holtxt{]}) as delimiters would
 conflict with the concrete syntax for list literals if this was done.
 Given that list literals are effectively of the \ml{CloseFix}

Modified: HOL/examples/HolCheck/muSyntaxScript.sml
===================================================================
--- HOL/examples/HolCheck/muSyntaxScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/examples/HolCheck/muSyntaxScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -52,7 +52,7 @@
 val mu_size2_def = Define `mu_size2 (f: 'prop mu) = mu_size (\(a:('prop)).0) f`
 
 val _ = add_rule
-    {term_name = "AP", fixity = TruePrefix 950, (* 950 is tighter than ~ *)
+    {term_name = "AP", fixity = Prefix 950, (* 950 is tighter than ~ *)
      pp_elements = [TOK "AP", HardSpace 1],
      paren_style = OnlyIfNecessary,
      block_style = (AroundSamePrec, (PP.INCONSISTENT, 0))}
@@ -73,20 +73,20 @@
 (* Need to use << and >> because of precedence conflicts with < and > *)
 
 (* prec 2501 is higher fixity than any thing in default term grammar WIP: does this make sense...not really, should be lower *)
-val _ = add_rule {term_name = "DIAMOND", fixity = TruePrefix 2501,
+val _ = add_rule {term_name = "DIAMOND", fixity = Prefix 2501,
      pp_elements = [TOK "<<", TM, TOK ">>", HardSpace 1],
      paren_style = OnlyIfNecessary,
      block_style = (AroundSamePrec, (PP.INCONSISTENT, 0))}
 (* Could actually use [ and ] here by declaring CloseFix fixity. But this is for consistency with lfp *)
-val _ = add_rule {term_name = "BOX", fixity = TruePrefix 2501,
+val _ = add_rule {term_name = "BOX", fixity = Prefix 2501,
      pp_elements = [TOK "[[", TM, TOK "]]",HardSpace 1],
      paren_style = OnlyIfNecessary,
      block_style = (AroundSamePrec, (PP.INCONSISTENT, 0))}
-val _ = add_rule {term_name = "mu", fixity = TruePrefix 2,
+val _ = add_rule {term_name = "mu", fixity = Prefix 2,
      pp_elements = [TOK "mu",HardSpace 1, TM, TOK "..",HardSpace 1],
      paren_style = OnlyIfNecessary,
      block_style = (AroundSamePrec, (PP.INCONSISTENT, 0))}
-val _ = add_rule {term_name = "nu", fixity = TruePrefix 2,
+val _ = add_rule {term_name = "nu", fixity = Prefix 2,
      pp_elements = [TOK "nu", HardSpace 1, TM, TOK "..",HardSpace 1],
      paren_style = OnlyIfNecessary,
      block_style = (AroundSamePrec, (PP.INCONSISTENT, 0))}

Modified: HOL/examples/acl2/examples/M1/sexpScript.sml
===================================================================
--- HOL/examples/acl2/examples/M1/sexpScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/examples/acl2/examples/M1/sexpScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -1248,7 +1248,7 @@
 (*****************************************************************************)
 (* |= t, where t:sexp, means t is a theorem of ACL2                          *)
 (*****************************************************************************)
-val _ = set_fixity "|=" (TruePrefix 11);        (* Give "|=" weak precedence *)
+val _ = set_fixity "|=" (Prefix 11);        (* Give "|=" weak precedence *)
 
 val ACL2_TRUE_def =
  xDefine "ACL2_TRUE"

Modified: HOL/examples/acl2/examples/acl2-hol-ltl-paper-example/sexpScript.sml
===================================================================
--- HOL/examples/acl2/examples/acl2-hol-ltl-paper-example/sexpScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/examples/acl2/examples/acl2-hol-ltl-paper-example/sexpScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -1248,7 +1248,7 @@
 (*****************************************************************************)
 (* |= t, where t:sexp, means t is a theorem of ACL2                          *)
 (*****************************************************************************)
-val _ = set_fixity "|=" (TruePrefix 11);        (* Give "|=" weak precedence *)
+val _ = set_fixity "|=" (Prefix 11);        (* Give "|=" weak precedence *)
 
 val ACL2_TRUE_def =
  xDefine "ACL2_TRUE"

Modified: HOL/examples/acl2/examples/example_axiomsScript.ml
===================================================================
--- HOL/examples/acl2/examples/example_axiomsScript.ml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/examples/acl2/examples/example_axiomsScript.ml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -39,7 +39,7 @@
 (* |= p is defined below to mean "p is true in the HOL model of ACL2"        *)
 (*                                                                           *)
 (*****************************************************************************)
-set_fixity "|=" (TruePrefix 11);                (* Give "|=" weak precedence *)
+set_fixity "|=" (Prefix 11);                (* Give "|=" weak precedence *)
 val ACL2_THM_def =
  xDefine "ACL2_THM"
   `(|= p) = (not(equal p nil) = t)`;

Modified: HOL/examples/acl2/ml/make_sexp.ml
===================================================================
--- HOL/examples/acl2/ml/make_sexp.ml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/examples/acl2/ml/make_sexp.ml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -951,7 +951,7 @@
 (*****************************************************************************)
 (* |= t, where t:sexp, means t is a theorem of ACL2                          *)
 (*****************************************************************************)
-val _ = set_fixity "|=" (TruePrefix 11);        (* Give "|=" weak precedence *)
+val _ = set_fixity "|=" (Prefix 11);        (* Give "|=" weak precedence *)
 
 val ACL2_TRUE_def =
  xDefine "ACL2_TRUE"

Modified: HOL/examples/acl2/ml/sexpScript.sml
===================================================================
--- HOL/examples/acl2/ml/sexpScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/examples/acl2/ml/sexpScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -1248,7 +1248,7 @@
 (*****************************************************************************)
 (* |= t, where t:sexp, means t is a theorem of ACL2                          *)
 (*****************************************************************************)
-val _ = set_fixity "|=" (TruePrefix 11);        (* Give "|=" weak precedence *)
+val _ = set_fixity "|=" (Prefix 11);        (* Give "|=" weak precedence *)
 
 val ACL2_TRUE_def =
  xDefine "ACL2_TRUE"

Modified: HOL/examples/lambda/barendregt/labelledTermsScript.sml
===================================================================
--- HOL/examples/lambda/barendregt/labelledTermsScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/examples/lambda/barendregt/labelledTermsScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -795,7 +795,7 @@
   ]);
 
 fun mk_def(s,t) =
-    {def_name = s ^ "_def", fixity = Prefix, fname = s, func = t};
+    {def_name = s ^ "_def", fixity = NONE, fname = s, func = t};
 
 (* some trivialities that are either needed for the lifting, or which are
    wanted to be part of it *)

Modified: HOL/examples/lambda/basics/generic_termsScript.sml
===================================================================
--- HOL/examples/lambda/basics/generic_termsScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/examples/lambda/basics/generic_termsScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -507,7 +507,7 @@
    ---------------------------------------------------------------------- *)
 
 fun mk_def(s,t) =
-    {def_name = s ^ "_def", fixity = Prefix, fname = s, func = t};
+    {def_name = s ^ "_def", fixity = NONE, fname = s, func = t};
 
 val ptpm_fv' =
     ptpm_fv |> CONJUNCT1 |> REWRITE_RULE [EXTENSION]

Modified: HOL/examples/lambda/basics/termScript.sml
===================================================================
--- HOL/examples/lambda/basics/termScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/examples/lambda/basics/termScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -29,7 +29,7 @@
   Induct_on `aeq` THEN SRW_TAC [][psize_def, psize_ptpm]);
 
 fun mk_def(s,t) =
-    {def_name = s ^ "_def", fixity = Prefix, fname = s, func = t};
+    {def_name = s ^ "_def", fixity = NONE, fname = s, func = t};
 val app_respects_aeq = List.nth(CONJUNCTS aeq_rules, 1)
 
 val ptpm_fv' = (CONV_RULE (BINDER_CONV

Modified: HOL/examples/lambda/examples/holScript.sml
===================================================================
--- HOL/examples/lambda/examples/holScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/examples/lambda/examples/holScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -363,7 +363,7 @@
   METIS_TAC [aeq_refl, aeq_sym, aeq_trans]);
 
 fun mk_def(s,t) =
-    {def_name = s ^ "_def", fixity = Prefix, fname = s, func = t};
+    {def_name = s ^ "_def", fixity = NONE, fname = s, func = t};
 
 
 fun m th = SIMP_RULE (bool_ss ++ boolSimps.DNF_ss) [] th

Modified: HOL/examples/lambda/typing/type_schemasScript.sml
===================================================================
--- HOL/examples/lambda/typing/type_schemasScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/examples/lambda/typing/type_schemasScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -523,7 +523,7 @@
   METIS_TAC [avoid_finite_set, FINITE_fv, aeq_rtypm]);
 
 val tyfun_respects_aeq = List.nth(CONJUNCTS aeq_rules, 1)
-fun mk_def (n,t) = {def_name = n ^ "_def", fname = n, func = t, fixity = Prefix}
+fun mk_def (n,t) = {def_name = n ^ "_def", fname = n, func = t, fixity = NONE}
 
 val okpm_respects = prove(
   ``!t1 t2. aeq t1 t2 ==> (okpm pi vs avoids t1 =

Modified: HOL/examples/unification/triangular/nominal/ntermScript.sml
===================================================================
--- HOL/examples/unification/triangular/nominal/ntermScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/examples/unification/triangular/nominal/ntermScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -65,7 +65,7 @@
 
 fun mk_def(t) =
 let val s = (String.extract(term_to_string t,1,NONE)) in
-  {def_name = s ^ "_def", fixity = Prefix, fname = s, func = t}
+  {def_name = s ^ "_def", fixity = NONE, fname = s, func = t}
 end;
 
 val [nterm_induction,nterm_nchotomy,ntermeq_thm]

Modified: HOL/help/Docfiles/Parse.add_rule.doc
===================================================================
--- HOL/help/Docfiles/Parse.add_rule.doc	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/help/Docfiles/Parse.add_rule.doc	2011-06-22 05:10:03 UTC (rev 9135)
@@ -38,25 +38,14 @@
    val RIGHT      : HOLgrammars.associativity
    val NONASSOC   : HOLgrammars.associativity
 
-   val Prefix     : fixity
    val Binder     : fixity
    val Closefix   : fixity
    val Infixl     : int -> fixity
    val Infixr     : int -> fixity
    val Infix      : HOLgrammars.associativity * int -> fixity
-   val TruePrefix : int -> fixity
+   val Prefix     : int -> fixity
    val Suffix     : int -> fixity
 }
-The {Prefix} fixity has an unfortunate name, as it is a fixity
-corresponding to no special treatment.  In fact, when a {Prefix}
-fixity is specified, the {add_rule} function performs no action.
-When an element list is meant to form a genuine prefix, the
-{TruePrefix} fixity must be used instead, as is done below in the
-conditional expression example and as is also done with {~} (logical
-negation).  The {Prefix} fixity is useful elsewhere, in situations
-where standard interfaces require fixities to be provided, but where
-the user may wish to leave an identifier as a normal symbol.
-
 The {Binder} fixity is for binders such as universal and existential
 quantifiers ({!} and {?}).  Binders can actually be seen as (true)
 prefixes (should {`!x. p /\ q`} be parsed as {`(!x. p) /\ q`} or as
@@ -84,7 +73,7 @@
 sub-terms depending on the fixity type, thus:
 {
    Closefix    :      [Kernel]     (* no external arguments *)
-   TruePrefix  :      [Kernel] _   (* an argument to the right *)
+   Prefix      :      [Kernel] _   (* an argument to the right *)
    Suffix      :    _ [Kernel]     (* an argument to the left *)
    Infix       :    _ [Kernel] _   (* arguments on both sides *)
 }
@@ -208,13 +197,13 @@
 }
 The second rule added uses the more familiar {if-then-else}
 syntax.  Here there is only a ``dangling'' term to the right of the
-construction, so this rule's fixity is of type {TruePrefix}. (If the
+construction, so this rule's fixity is of type {Prefix}. (If the
 rule was made a {Closefix}, strings such as {`if P then Q else R`}
 would still parse, but so too would {`if P then Q else`}.)  This
 example also illustrates the use of blocks within rules to improve
 pretty-printing.
 {
-   val _ = add_rule{term_name = "COND", fixity = TruePrefix 70,
+   val _ = add_rule{term_name = "COND", fixity = Prefix 70,
                     pp_elements = [PPBlock([TOK "if", BreakSpace(1,2),
                                             TM, BreakSpace(1,0),
                                             TOK "then"], (PP.CONSISTENT, 0)),
@@ -254,12 +243,6 @@
 grammar, but which does not cause this effect to persist when the
 current theory is exported.
 
-The {Prefix}/{TruePrefix} situation may be transitory.  It has the
-advantage of maintaining a deal of backwards compatibility, but at the
-cost of confusing the terminology.  Where the {Prefix} value is
-acceptable, the {fixity} type should be replaced by a {fixity option}
-type to better reflect the semantics of what is really happening.
-
 An Isabelle-style concrete syntax for specifying rules would probably
 be desirable as it would conceal the complexity of the above from most
 users.

Modified: HOL/src/1/Drule.sml
===================================================================
--- HOL/src/1/Drule.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/1/Drule.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -1759,8 +1759,8 @@
   in Rsyntax.new_specification
       {name=name,
        sat_thm=MP(SPEC P (INST_TYPE[beta |-> a, alpha |-> r]ABS_REP_THM)) tyax,
-       consts = [{const_name=REP, fixity=Prefix},
-                 {const_name=ABS, fixity=Prefix}]}
+       consts = [{const_name=REP, fixity=NONE},
+                 {const_name=ABS, fixity=NONE}]}
   end
   handle e => raise (wrap_exn "Drule" "define_new_type_bijections" e)
 

Modified: HOL/src/1/Prim_rec.sml
===================================================================
--- HOL/src/1/Prim_rec.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/1/Prim_rec.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -261,7 +261,7 @@
   Rsyntax.new_specification
     {sat_thm=eth, name=name,
      consts = map (fn t => {const_name = fst(dest_var t),
-                            fixity = Parse.Prefix}) evs }
+                            fixity = NONE}) evs }
  end;
 
 (* test with:

Modified: HOL/src/1/Rsyntax.sig
===================================================================
--- HOL/src/1/Rsyntax.sig	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/1/Rsyntax.sig	2011-06-22 05:10:03 UTC (rev 9135)
@@ -45,7 +45,7 @@
   val new_specification : {name    : string,
                            sat_thm : thm,
                            consts  : {const_name : string,
-                                      fixity : Parse.fixity} list} -> thm
+                                      fixity : Parse.fixity option} list} -> thm
   datatype lambda
      = VAR   of {Name:string, Ty:hol_type}
      | CONST of {Name:string, Thy:string, Ty:hol_type}

Modified: HOL/src/1/Rsyntax.sml
===================================================================
--- HOL/src/1/Rsyntax.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/1/Rsyntax.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -58,9 +58,8 @@
   open Parse
   val cnames = map #const_name consts
   val res = Definition.new_specification(name, cnames, sat_thm)
-  fun modify_grammar {const_name,fixity} = if fixity <> Prefix then
-                                             set_fixity const_name fixity
-                                           else ()
+  fun modify_grammar {const_name,fixity=SOME fxty} = set_fixity const_name fxty
+    | modify_grammar _ = ()
 in
   app modify_grammar consts;
   res

Modified: HOL/src/TeX/selftest.sml
===================================================================
--- HOL/src/TeX/selftest.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/TeX/selftest.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -19,12 +19,12 @@
 val _ = tprint "Testing syntactic-sugar overriding"
 val _ = temp_remove_rules_for_term "~"
 val _ = temp_add_rule {term_name   = "~",
-                       fixity      = TruePrefix 900,
+                       fixity      = Prefix 900,
                        pp_elements = [TOK "TOK1"],
                        paren_style = OnlyIfNecessary,
                        block_style = (AroundEachPhrase, (CONSISTENT, 0))}
 val _ = temp_add_rule {term_name   = "I",
-                       fixity      = TruePrefix 900,
+                       fixity      = Prefix 900,
                        pp_elements = [TOK "TOK2"],
                        paren_style = OnlyIfNecessary,
                        block_style = (AroundEachPhrase, (CONSISTENT, 0))}

Modified: HOL/src/bool/boolScript.sml
===================================================================
--- HOL/src/bool/boolScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/bool/boolScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -177,7 +177,7 @@
 
 open Portable;
 val _ = add_rule {term_name   = "~",
-                  fixity      = TruePrefix 900,
+                  fixity      = Prefix 900,
                   pp_elements = [TOK "~"],
                   paren_style = OnlyIfNecessary,
                   block_style = (AroundEachPhrase, (CONSISTENT, 0))};
@@ -189,7 +189,7 @@
    the pretty-printer handles these specially.  These declarations are only
    for the parser's benefit. *)
 val _ = add_rule {term_name   = GrammarSpecials.let_special,
-                  fixity = TruePrefix 2,
+                  fixity = Prefix 2,
                   pp_elements = [TOK "let", BreakSpace(1,0), TM,
                                  BreakSpace(1, 0), TOK "in",
                                  BreakSpace(1, 0)],
@@ -203,7 +203,7 @@
                   block_style = (AroundEachPhrase, (INCONSISTENT, 0))}
 
 val _ = add_rule{term_name   = "COND",
-                 fixity      = TruePrefix 70,
+                 fixity      = Prefix 70,
                  pp_elements = [PPBlock([TOK "if", BreakSpace(1,2), TM,
                                          BreakSpace(1,0),
                                          TOK "then"], (CONSISTENT, 0)),
@@ -4346,7 +4346,7 @@
                                          TM, BreakSpace(1,2), TOK "of"],
                                         (PP.CONSISTENT, 0)),
                                 BreakSpace(1,3)],
-                 fixity = TruePrefix 7,
+                 fixity = Prefix 7,
                  block_style = (AroundEachPhrase, (PP.CONSISTENT, 0)),
                  paren_style = OnlyIfNecessary,
                  term_name = GrammarSpecials.case_special};

Modified: HOL/src/datatype/equiv/EquivType.sig
===================================================================
--- HOL/src/datatype/equiv/EquivType.sig	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/datatype/equiv/EquivType.sig	2011-06-22 05:10:03 UTC (rev 9135)
@@ -4,7 +4,7 @@
 	    {name : string,
 	     equiv : Thm.thm,
 	     defs: {def_name:string, fname:string,
-                    func:Term.term, fixity: Parse.fixity} list,
+                    func:Term.term, fixity: Parse.fixity option} list,
 	     welldefs : Thm.thm list,
 	     old_thms : Thm.thm list}
 	    -> Thm.thm list

Modified: HOL/src/datatype/equiv/EquivType.sml
===================================================================
--- HOL/src/datatype/equiv/EquivType.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/datatype/equiv/EquivType.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -232,7 +232,7 @@
                         else r0
                   end
       in
-        if fixity <> Prefix then Parse.set_fixity fname fixity else ();
+        (case fixity of SOME fxty => Parse.set_fixity fname fxty | NONE => ());
         new_definition(def_name, mk_eq(l,r))
      end
 

Modified: HOL/src/datatype/ind_typeScript.sml
===================================================================
--- HOL/src/datatype/ind_typeScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/datatype/ind_typeScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -55,8 +55,8 @@
   SIMP_TAC hol_ss [EQ_MULT_LCANCEL, EQ_ADD_RCANCEL, EXP_EQ_0]);
 
 val NUMPAIR_DEST = Rsyntax.new_specification {
-  consts = [{const_name = "NUMFST", fixity = Prefix},
-            {const_name = "NUMSND", fixity = Prefix}],
+  consts = [{const_name = "NUMFST", fixity = NONE},
+            {const_name = "NUMSND", fixity = NONE}],
   name = "NUMPAIR_DEST",
   sat_thm = MATCH_MP INJ_INVERSE2 NUMPAIR_INJ};
 
@@ -77,8 +77,8 @@
   SIMP_TAC hol_ss [INV_SUC_EQ, EQ_MULT_LCANCEL]);
 
 val NUMSUM_DEST = Rsyntax.new_specification{
-  consts = [{const_name = "NUMLEFT", fixity = Prefix},
-            {const_name = "NUMRIGHT", fixity = Prefix}],
+  consts = [{const_name = "NUMLEFT", fixity = NONE},
+            {const_name = "NUMRIGHT", fixity = NONE}],
   name = "NUMSUM_DEST",
   sat_thm = MATCH_MP INJ_INVERSE2 NUMSUM_INJ};
 

Modified: HOL/src/integer/integerScript.sml
===================================================================
--- HOL/src/integer/integerScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/integer/integerScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -475,13 +475,13 @@
          int_of_num, INT_INJ, NUM_POSINT_EX] =
 	define_equivalence_type
 	{name = "int", equiv = TINT_EQ_EQUIV,
-	 defs = [mk_def ("int_0", Term `tint_0`,     "int_0", Prefix),
-		 mk_def ("int_1", Term `tint_1`,     "int_1", Prefix),
-		 mk_def ("int_neg",Term `tint_neg`,  "int_neg",   Prefix),
-		 mk_def ("int_add",Term `$tint_add`, "int_add",   Prefix),
-		 mk_def ("int_mul",Term `$tint_mul`, "int_mul",   Prefix),
-		 mk_def ("int_lt",Term `$tint_lt`,   "int_lt",    Prefix),
-                 mk_def ("int_of_num",Term `tint_of_num`,"int_of_num",Prefix)],
+	 defs = [mk_def ("int_0", Term `tint_0`,     "int_0", NONE),
+		 mk_def ("int_1", Term `tint_1`,     "int_1", NONE),
+		 mk_def ("int_neg",Term `tint_neg`,  "int_neg",   NONE),
+		 mk_def ("int_add",Term `$tint_add`, "int_add",   NONE),
+		 mk_def ("int_mul",Term `$tint_mul`, "int_mul",   NONE),
+		 mk_def ("int_lt",Term `$tint_lt`,   "int_lt",    NONE),
+                 mk_def ("int_of_num",Term `tint_of_num`,"int_of_num",NONE)],
 
 	 welldefs = [TINT_NEG_WELLDEF, TINT_LT_WELLDEF,
 		     TINT_ADD_WELLDEF, TINT_MUL_WELLDEF],

Modified: HOL/src/list/src/listScript.sml
===================================================================
--- HOL/src/list/src/listScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/list/src/listScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -245,7 +245,7 @@
   in
       Rsyntax.new_specification{
         name = "MAP2", sat_thm = lemma,
-        consts = [{const_name="MAP2", fixity=Prefix}]
+        consts = [{const_name="MAP2", fixity=NONE}]
       }
   end
 
@@ -1174,7 +1174,7 @@
      end)
     in
     Rsyntax.new_specification
-        {consts = [{const_name = "ZIP", fixity = Prefix}],
+        {consts = [{const_name = "ZIP", fixity = NONE}],
          name = "ZIP",
          sat_thm = lemma
         }

Modified: HOL/src/list/src/rich_listScript.sml
===================================================================
--- HOL/src/list/src/rich_listScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/list/src/rich_listScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -418,7 +418,7 @@
     in
     Rsyntax.new_specification{name = "SEG",
                       sat_thm = SEG_exists,
-                      consts =  [{const_name = "SEG", fixity = Prefix}]
+                      consts =  [{const_name = "SEG", fixity = NONE}]
                      }
     end;
 
@@ -448,7 +448,7 @@
    in
     Rsyntax.new_specification{name = "LASTN",
                       sat_thm = thm,
-                      consts =  [{const_name = "LASTN", fixity = Prefix}]
+                      consts =  [{const_name = "LASTN", fixity = NONE}]
                      }
    end;
 
@@ -464,7 +464,7 @@
     in
     Rsyntax.new_specification{name = "BUTLASTN",
                       sat_thm = thm,
-                      consts =  [{const_name = "BUTLASTN", fixity = Prefix}]
+                      consts =  [{const_name = "BUTLASTN", fixity = NONE}]
                      }
     end;
 
@@ -561,7 +561,7 @@
     end)
   in
     Rsyntax.new_specification
-        {consts = [{const_name = "IS_SUFFIX", fixity = Prefix}],
+        {consts = [{const_name = "IS_SUFFIX", fixity = NONE}],
          name = "IS_SUFFIX",
          sat_thm = lemma
         }
@@ -585,7 +585,7 @@
         end)
     in
     Rsyntax.new_specification
-        {consts = [{const_name = "IS_SUBLIST", fixity = Prefix}],
+        {consts = [{const_name = "IS_SUBLIST", fixity = NONE}],
          name = "IS_SUBLIST",
          sat_thm = lemma
         }
@@ -3321,7 +3321,7 @@
 
    val REPLACE_ELEMENT_DEF = Rsyntax.new_specification{name = "REPLACE_ELEMENT_DEF",
                       sat_thm = REPLACE_ELEMENT_exists,
-                      consts =  [{const_name = "REPLACE_ELEMENT", fixity = Prefix}]
+                      consts =  [{const_name = "REPLACE_ELEMENT", fixity = NONE}]
                      };
 end;
 

Modified: HOL/src/num/theories/arithmeticScript.sml
===================================================================
--- HOL/src/num/theories/arithmeticScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/num/theories/arithmeticScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -103,7 +103,7 @@
      integer, real, words, rat
 *)
 val _ = add_rule { term_name = "numeric_negate",
-                   fixity = TruePrefix 900,
+                   fixity = Prefix 900,
                    pp_elements = [TOK "-"],
                    paren_style = OnlyIfNecessary,
                    block_style = (AroundEachPhrase, (PP.CONSISTENT,0))};
@@ -111,7 +111,7 @@
 (* Similarly, add syntax for the injection from nats symbol (&).  This isn't
    required in this theory, but will be used by descendents. *)
 val _ = add_rule {term_name = GrammarSpecials.num_injection,
-                  fixity = TruePrefix 900,
+                  fixity = Prefix 900,
                   pp_elements = [TOK GrammarSpecials.num_injection],
                   paren_style = OnlyIfNecessary,
                   block_style = (AroundEachPhrase, (PP.CONSISTENT,0))};

Modified: HOL/src/parse/Parse.sig
===================================================================
--- HOL/src/parse/Parse.sig	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/parse/Parse.sig	2011-06-22 05:10:03 UTC (rev 9135)
@@ -13,7 +13,6 @@
 
   datatype fixity
      = RF of term_grammar.rule_fixity
-     | Prefix
      | Binder
   val fixityToString : fixity -> string
 
@@ -250,10 +249,10 @@
   val Infixl     : int -> fixity
   val Infixr     : int -> fixity
   val Infix      : associativity * int -> fixity
-  val TruePrefix : int -> fixity
+  val Prefix     : int -> fixity
   val Closefix   : fixity
   val Suffix     : int -> fixity
-  val fixity     : string -> fixity
+  val fixity     : string -> fixity option
 
   (* more constructors/values that come across from term_grammar *)
 

Modified: HOL/src/parse/Parse.sml
===================================================================
--- HOL/src/parse/Parse.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/parse/Parse.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -17,8 +17,6 @@
 val post_process_term = Preterm.post_process_term
 val quote = Lib.mlquote
 
-datatype fixity = RF of term_grammar.rule_fixity | Prefix | Binder
-
 fun acc_strip_comb M rands =
   let val (Rator,Rand) = dest_comb M
   in acc_strip_comb Rator (Rand::rands)
@@ -49,20 +47,19 @@
 
 datatype fixity
     = RF of rule_fixity
-    | Prefix
     | Binder
 
 fun Infix x = x;  (* namespace hackery *)
 fun Suffix x = x;
 fun Closefix x = x;
-fun TruePrefix x = x;
+fun Prefix x = x;
 
 val Infix        = fn (a,i) => RF (term_grammar.Infix (a,i))
 val Infixl       = fn i => Infix(LEFT, i)
 val Infixr       = fn i => Infix(RIGHT, i)
 val Suffix       = fn n => RF (term_grammar.Suffix n)
 val Closefix     = RF term_grammar.Closefix
-val TruePrefix   = fn n => RF (term_grammar.TruePrefix n)
+val Prefix       = fn n => RF (term_grammar.Prefix n)
 
 
 (*---------------------------------------------------------------------------
@@ -113,10 +110,10 @@
 
 fun fixity s =
   case term_grammar.get_precedence (term_grammar()) s
-   of SOME rf => RF rf
+   of SOME rf => SOME (RF rf)
     | NONE => if Lib.mem s (term_grammar.binders (term_grammar()))
-                 then Binder
-                 else Prefix
+                 then SOME Binder
+                 else NONE
 
 (*---------------------------------------------------------------------------
        Mysterious stuff
@@ -585,7 +582,7 @@
   val ppels =
       case fixity of
         Infix _ => [HardSpace 1, RE (TOK tok), BreakSpace(1,0)]
-      | TruePrefix _ => [RE(TOK tok), HardSpace 1]
+      | Prefix _ => [RE(TOK tok), HardSpace 1]
       | Suffix _     => [HardSpace 1, RE(TOK tok)]
       | Closefix  => [RE(TOK tok)]
 in
@@ -617,24 +614,20 @@
     case f of
       RF (Infix(_, p)) => SOME p
     | RF (Suffix p) => SOME p
-    | RF (TruePrefix p) => SOME p
+    | RF (Prefix p) => SOME p
     | RF Closefix => NONE
-    | Prefix => NONE
     | Binder => SOME std_binder_precedence
   end
 
-  exception foo
   fun uset_fixity0 setter s fxty = let
     open term_grammar
     val rule =
       case fxty of
-        Prefix => (HOL_MESG "Fixities of Prefix do not affect the grammar";
-                   raise foo)
-      | Binder => BRULE {tok = s, term_name = s}
+        Binder => BRULE {tok = s, term_name = s}
       | RF rf => GRULE (standard_spacing s rf)
   in
     lift setter {u = [s], term_name = s, newrule = rule, oldtok = NONE}
-  end handle foo => ()
+  end
 
   val temp_uset_fixity = uset_fixity0 ProvideUnicode.temp_uadd_rule
   val uset_fixity = uset_fixity0 ProvideUnicode.uadd_rule
@@ -794,8 +787,7 @@
 
 local open term_grammar
 in
-fun fixityToString Prefix  = "Prefix"
-  | fixityToString Binder  = "Binder"
+fun fixityToString Binder  = "Binder"
   | fixityToString (RF rf) = term_grammar.rule_fixityToString rf
 
 fun relToString TM = "TM"
@@ -882,8 +874,7 @@
   open term_grammar
 in
   case fixity of
-    Prefix => Error "Fixities of Prefix do not affect the grammar"
-  | Binder => let
+    Binder => let
     in
       case rule_elements pp_elements of
         [TOK s] => Some (BRULE {term_name = term_name, tok = s})
@@ -1065,8 +1056,7 @@
 in
   temp_remove_termtok nmtok;
   case fixity of
-    Prefix => ()
-  | RF rf => temp_add_grule
+    RF rf => temp_add_grule
                  (GRULE (standard_mapped_spacing {fixity = rf, tok = tok,
                                                   term_name = term_name}))
   | Binder => if term_name <> tok then

Modified: HOL/src/parse/ProvideUnicode.sml
===================================================================
--- HOL/src/parse/ProvideUnicode.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/parse/ProvideUnicode.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -100,7 +100,7 @@
                             blist
             end
           | PREFIX (STD_prefix rrlist) =>
-            search_rrlist (TruePrefix (valOf fixopt)) tf_opt
+            search_rrlist (Prefix (valOf fixopt)) tf_opt
                           (fn tfopt => get_rule_data tfopt rest)
                           rrlist
           | SUFFIX TYPE_annotation => get_rule_data tf_opt rest

Modified: HOL/src/parse/term_grammar.sig
===================================================================
--- HOL/src/parse/term_grammar.sig	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/parse/term_grammar.sig	2011-06-22 05:10:03 UTC (rev 9135)
@@ -84,7 +84,7 @@
      = Infix of associativity * int
      | Closefix
      | Suffix of int
-     | TruePrefix of int
+     | Prefix of int
 
   datatype user_delta =
            GRULE of {term_name : string,

Modified: HOL/src/parse/term_grammar.sml
===================================================================
--- HOL/src/parse/term_grammar.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/parse/term_grammar.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -98,7 +98,7 @@
        | LISTRULE of listspec list
 
 datatype rule_fixity =
-  Infix of associativity * int | Closefix | Suffix of int | TruePrefix of int
+  Infix of associativity * int | Closefix | Suffix of int | Prefix of int
 
 datatype user_delta =
          GRULE of {term_name : string,
@@ -805,7 +805,7 @@
     Infix(a,i) => "Infix("^assocToString a^", "^Int.toString i^")"
   | Closefix => "Closefix"
   | Suffix p => "Suffix "^Int.toString p
-  | TruePrefix p => "TruePrefix "^Int.toString p
+  | Prefix p => "Prefix "^Int.toString p
 
 
 fun rrec2delta rf (rr : rule_record) = let
@@ -853,7 +853,7 @@
           case grule of
             PREFIX (BINDER blist) => search (search_blist acc blist) rest
           | PREFIX (STD_prefix rrlist) =>
-            search (search_rrlist (TruePrefix (valOf fixopt)) acc rrlist)
+            search (search_rrlist (Prefix (valOf fixopt)) acc rrlist)
                    rest
           | SUFFIX (STD_suffix rrlist) =>
             search (search_rrlist (Suffix (valOf fixopt)) acc rrlist)
@@ -881,7 +881,7 @@
     case f of
       Infix (a,p) => (SOME p, INFIX(STD_infix([rr], a)))
     | Suffix p => (SOME p, SUFFIX (STD_suffix [rr]))
-    | TruePrefix p => (SOME p, PREFIX (STD_prefix [rr]))
+    | Prefix p => (SOME p, PREFIX (STD_prefix [rr]))
     | Closefix => (NONE, CLOSEFIX [rr])
 in
   G0 Gmerge [new_rule]
@@ -980,7 +980,7 @@
         if elmem s elms then SOME(Infix(assoc, valOf p))
         else NONE
     | PREFIX(STD_prefix elms) =>
-          if elmem s elms then SOME (TruePrefix (valOf p))
+          if elmem s elms then SOME (Prefix (valOf p))
           else NONE
     | SUFFIX (STD_suffix elms) => if elmem s elms then SOME (Suffix (valOf p))
                                   else NONE
@@ -1508,12 +1508,12 @@
     case f of
       Infix(a,p) => "I" ^ assoc_encode a ^ IntData.encode p
     | Suffix p => "S" ^ IntData.encode p
-    | TruePrefix p => "T" ^ IntData.encode p
+    | Prefix p => "P" ^ IntData.encode p
     | Closefix => "C"
 val fixity_reader =
     (literal "I" >> map Infix (assoc_reader >* IntData.reader)) ||
     (literal "S" >> map Suffix IntData.reader) ||
-    (literal "T" >> map TruePrefix IntData.reader) ||
+    (literal "P" >> map Prefix IntData.reader) ||
     (literal "C" >> return Closefix)
 
 fun user_delta_encode ud =

Modified: HOL/src/pred_set/src/pred_setScript.sml
===================================================================
--- HOL/src/pred_set/src/pred_setScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/pred_set/src/pred_setScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -238,10 +238,10 @@
      REWRITE_TAC [EXTENSION,IN_UNIV]);
 
 val _ = overload_on ("univ", ``\x:'a itself. UNIV : 'a set``)
-val _ = set_fixity "univ" (TruePrefix 2200)
+val _ = set_fixity "univ" (Prefix 2200)
 
 val _ = overload_on (UnicodeChars.universal_set, ``\x:'a itself. UNIV: 'a set``)
-val _ = set_fixity UnicodeChars.universal_set (TruePrefix 2200)
+val _ = set_fixity UnicodeChars.universal_set (Prefix 2200)
 
 fun univ_printer (tyg, tmg) backend printer ppfns gravs depth tm = let
   open smpp infix >>

Modified: HOL/src/quotient/examples/ext_finite_setScript.sml
===================================================================
--- HOL/src/quotient/examples/ext_finite_setScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/quotient/examples/ext_finite_setScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -277,47 +277,47 @@
     [{def_name="Empty_def",
       fname="Empty",
       func= ``[] :'a list``,
-      fixity=Prefix},
+      fixity=NONE},
 
      {def_name="Insert_def",
       fname="Insert",
       func= ``CONS :'a -> 'a list -> 'a list``,
-      fixity=Infixr 490},
+      fixity=SOME(Infixr 490)},
 
      {def_name="In_def",
       fname="In",
       func= ``MEM :'a -> 'a list -> bool``,
-      fixity=Infix(NONASSOC,425)},
+      fixity=SOME(Infix(NONASSOC,425))},
 
      {def_name="Card_def",
       fname="Card",
       func= ``Card1 :'a list -> num``,
-      fixity=Prefix},
+      fixity=NONE},
 
      {def_name="Delete_def",
       fname="Delete",
       func= ``$Delete1 :'a list -> 'a -> 'a list``,
-      fixity=Infixl 500},
+      fixity=SOME(Infixl 500)},
 
      {def_name="Union_def",
       fname="Union",
       func= ``APPEND :'a list -> 'a list -> 'a list``,
-      fixity=Infixl 500},
+      fixity=SOME(Infixl 500)},
 
      {def_name="Inter_def",
       fname="Inter",
       func= ``$Inter1 :'a list -> 'a list -> 'a list``,
-      fixity=Infixl 600},
+      fixity=SOME(Infixl 600)},
 
      {def_name="Fold_def",
       fname="Fold",
       func= ``Fold1 :('a -> 'b -> 'b) -> 'b -> 'a list -> 'b``,
-      fixity=Prefix},
+      fixity=NONE},
 
      {def_name="fset2set_def",
       fname="fset2set",
       func= ``LIST_TO_SET :'a list -> 'a -> bool``,
-      fixity=Prefix}
+      fixity=NONE}
     ];
 
 

Modified: HOL/src/quotient/examples/finite_setScript.sml
===================================================================
--- HOL/src/quotient/examples/finite_setScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/quotient/examples/finite_setScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -507,47 +507,47 @@
     [{def_name="Empty_def",
       fname="Empty",
       func= ``[] :'a list``,
-      fixity=Prefix},
+      fixity=NONE},
 
      {def_name="Insert_def",
       fname="Insert",
       func= ``CONS :'a -> 'a list -> 'a list``,
-      fixity=Infixr 490},
+      fixity=SOME(Infixr 490)},
 
      {def_name="In_def",
       fname="In",
       func= ``MEM :'a -> 'a list -> bool``,
-      fixity=Infix(NONASSOC,425)},
+      fixity=SOME(Infix(NONASSOC,425))},
 
      {def_name="Card_def",
       fname="Card",
       func= ``Card1 :'a list -> num``,
-      fixity=Prefix},
+      fixity=NONE},
 
      {def_name="Delete_def",
       fname="Delete",
       func= ``$Delete1 :'a list -> 'a -> 'a list``,
-      fixity=Infixl 500},
+      fixity=SOME(Infixl 500)},
 
      {def_name="Union_def",
       fname="Union",
       func= ``APPEND :'a list -> 'a list -> 'a list``,
-      fixity=Infixl 500},
+      fixity=SOME(Infixl 500)},
 
      {def_name="Inter_def",
       fname="Inter",
       func= ``$Inter1 :'a list -> 'a list -> 'a list``,
-      fixity=Infixl 600},
+      fixity=SOME(Infixl 600)},
 
      {def_name="Fold_def",
       fname="Fold",
       func= ``Fold1 :('b -> 'b -> 'b) -> ('a -> 'b) -> 'b -> 'a list -> 'b``,
-      fixity=Prefix},
+      fixity=NONE},
 
      {def_name="fset2set_def",
       fname="fset2set",
       func= ``list2set :'a list -> 'a -> bool``,
-      fixity=Prefix}
+      fixity=NONE}
     ];
 
 

Modified: HOL/src/quotient/examples/lambda/liftScript.sml
===================================================================
--- HOL/src/quotient/examples/lambda/liftScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/quotient/examples/lambda/liftScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -877,35 +877,35 @@
 val equivs = [ALPHA_EQUIV];
 
 val fnlist = [{def_name="Con_def", fname="Con",
-               func= (--`Con1 :'a->^term`--), fixity=Prefix
+               func= (--`Con1 :'a->^term`--), fixity=NONE
                                         (* see structure Parse *)},
               {def_name="Var_def", fname="Var",
-               func= (--`Var1 :var -> ^term`--), fixity=Prefix},
+               func= (--`Var1 :var -> ^term`--), fixity=NONE},
               {def_name="App_def", fname="App",
                func= (--`App1 :^term -> ^term -> ^term`--),
-               fixity=Prefix},
+               fixity=NONE},
               {def_name="Lam_def", fname="Lam",
-               func= (--`Lam1 :var -> ^term -> ^term`--), fixity=Prefix},
+               func= (--`Lam1 :var -> ^term -> ^term`--), fixity=NONE},
               {def_name="Abs_def", fname="Abs",
-               func= (--`Abs1 :(var -> ^term) -> ^term`--), fixity=Prefix},
+               func= (--`Abs1 :(var -> ^term) -> ^term`--), fixity=NONE},
               {def_name="HEIGHT_def", fname="HEIGHT",
-               func= (--`HEIGHT1 :^term -> num`--), fixity=Prefix},
+               func= (--`HEIGHT1 :^term -> num`--), fixity=NONE},
               {def_name="FV_def", fname="FV",
-               func= (--`FV1 :^term -> var -> bool`--), fixity=Prefix},
+               func= (--`FV1 :^term -> var -> bool`--), fixity=NONE},
               {def_name="SUB_def", fname="SUB",
-               func= (--`SUB1 :^subs -> var -> ^term`--), fixity=Prefix},
+               func= (--`SUB1 :^subs -> var -> ^term`--), fixity=NONE},
               {def_name="FV_subst_def", fname="FV_subst",
                func= (--`FV_subst1 :^subs -> (var -> bool) -> var -> bool`--),
-               fixity=Prefix},
+               fixity=NONE},
               {def_name="SUBt_def", fname="SUBt",
                func= (--`SUB1t :^term -> ^subs -> ^term`--),
-               fixity=Infix(NONASSOC,150)},
+               fixity=SOME(Infix(NONASSOC,150))},
               {def_name="vsubst_def", fname="/",
                func= (--`$// :var list -> var list -> ^subs`--),
-               fixity=Infix(NONASSOC,150)},
+               fixity=SOME(Infix(NONASSOC,150))},
               {def_name="subst_eq_def", fname="subst_eq",
                func= (--`ALPHA_subst:(var -> bool) ->^subs ->^subs -> bool`--),
-               fixity=Prefix}
+               fixity=NONE}
              ];
 
 

Modified: HOL/src/quotient/examples/lambda/more_setScript.sml
===================================================================
--- HOL/src/quotient/examples/lambda/more_setScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/quotient/examples/lambda/more_setScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -520,7 +520,7 @@
 val IN_UNION_SET =
     let val th1 = CONV_RULE SKOLEM_CONV UNION_SET_EXISTS in
     new_specification{name="IN_UNION_SET",
-                      consts=[{const_name="UNION_SET",fixity=Prefix}],
+                      consts=[{const_name="UNION_SET",fixity=NONE}],
                       sat_thm=th1}
     end
 end;

Modified: HOL/src/quotient/examples/lambda/variableScript.sml
===================================================================
--- HOL/src/quotient/examples/lambda/variableScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/quotient/examples/lambda/variableScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -366,7 +366,7 @@
     let val th1 = CONV_RULE SKOLEM_CONV variant_EXISTS in
        new_specification
          {name    = "variant",
-          consts  = [{const_name = "variant", fixity = Prefix (*700*)}],
+          consts  = [{const_name = "variant", fixity = NONE (*700*)}],
           sat_thm = th1}
     end
 end;

Modified: HOL/src/quotient/examples/msgScript.sml
===================================================================
--- HOL/src/quotient/examples/msgScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/quotient/examples/msgScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -265,24 +265,6 @@
 
 val equivs = [msgrel_EQUIV];
 
-val fnlist = [{def_name="Nonce_def",      fname="Nonce",
-               func= (--`Nonce1`--),      fixity=Prefix},
-              {def_name="Mpair_def",      fname="Mpair",
-               func= (--`Mpair1`--),      fixity=Prefix},
-              {def_name="Crypt_def",      fname="Crypt",
-               func= (--`Crypt1`--),      fixity=Prefix},
-              {def_name="Decrypt_def",    fname="Decrypt",
-               func= (--`Decrypt1`--),    fixity=Prefix},
-              {def_name="nonces_def",     fname="nonces",
-               func= (--`freenonces1`--), fixity=Prefix},
-              {def_name="left_def",       fname="left",
-               func= (--`freeleft1 `--),  fixity=Prefix},
-              {def_name="right_def",      fname="right",
-               func= (--`freeright1 `--), fixity=Prefix},
-              {def_name="is_nonce_def",    fname="is_nonce",
-               func= (--`is_nonce1 `--),  fixity=Prefix}
-             ];
-
 val old_thms =
      [msg1_cases,
       CD,
@@ -300,6 +282,7 @@
 (* ==================================================== *)
 
 val _ = quotient.chatting := true;
+fun mk_fn (nm,t) = {def_name=nm^"_def", fname = nm, func = t, fixity = NONE}
 
 val [msg_cases,
       msgCD,
@@ -312,7 +295,14 @@
      ] =
     define_quotient_types
     {types = [{name = "msg", equiv = msgrel_EQUIV}],
-     defs = fnlist,
+     defs = map mk_fn [("Nonce", ``Nonce1``),
+                       ("Mpair", ``Mpair1``),
+                       ("Crypt", ``Crypt1``),
+                       ("Decrypt", ``Decrypt1``),
+                       ("nonces", ``freenonces1``),
+                       ("left", ``freeleft1``),
+                       ("right", ``freeright1``),
+                       ("is_nonce", ``is_nonce1``)],
      tyop_equivs = [],
      tyop_quotients = [FUN_QUOTIENT],
      tyop_simps = [FUN_REL_EQ, FUN_MAP_I],

Modified: HOL/src/quotient/examples/sigma/liftScript.sml
===================================================================
--- HOL/src/quotient/examples/sigma/liftScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/quotient/examples/sigma/liftScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -1300,72 +1300,72 @@
 val equivs = [ALPHA_obj_EQUIV, ALPHA_method_EQUIV];
 
 val fnlist = [{def_name="OVAR_def", fname="OVAR",
-               func= (--`OVAR1 :var->^obj`--), fixity=Prefix
+               func= (--`OVAR1 :var->^obj`--), fixity=NONE
                                         (* see structure Parse *)},
               {def_name="OBJ_def", fname="OBJ",
-               func= (--`OBJ1 :^dict -> ^obj`--), fixity=Prefix},
+               func= (--`OBJ1 :^dict -> ^obj`--), fixity=NONE},
               {def_name="INVOKE_def", fname="INVOKE",
-               func= (--`INVOKE1 :^obj -> string -> ^obj`--), fixity=Prefix},
+               func= (--`INVOKE1 :^obj -> string -> ^obj`--), fixity=NONE},
               {def_name="UPDATE_def", fname="UPDATE",
                func= (--`UPDATE1 :^obj -> string -> ^method -> ^obj`--),
-               fixity=Prefix},
+               fixity=NONE},
               {def_name="SIGMA_def", fname="SIGMA",
-               func= (--`SIGMA1 :var -> ^obj -> ^method`--), fixity=Prefix},
+               func= (--`SIGMA1 :var -> ^obj -> ^method`--), fixity=NONE},
               {def_name="ABS_def", fname="ABS",
-               func= (--`ABS1 :(var -> ^obj) -> ^method`--), fixity=Prefix},
+               func= (--`ABS1 :(var -> ^obj) -> ^method`--), fixity=NONE},
               {def_name="HEIGHT_obj_def", fname="HEIGHT_obj",
-               func= (--`HEIGHT_obj1 :^obj -> num`--), fixity=Prefix},
+               func= (--`HEIGHT_obj1 :^obj -> num`--), fixity=NONE},
               {def_name="HEIGHT_dict_def", fname="HEIGHT_dict",
-               func= (--`HEIGHT_dict1 :^dict -> num`--), fixity=Prefix},
+               func= (--`HEIGHT_dict1 :^dict -> num`--), fixity=NONE},
               {def_name="HEIGHT_entry_def", fname="HEIGHT_entry",
-               func= (--`HEIGHT_entry1 :^entry -> num`--), fixity=Prefix},
+               func= (--`HEIGHT_entry1 :^entry -> num`--), fixity=NONE},
               {def_name="HEIGHT_method_def", fname="HEIGHT_method",
-               func= (--`HEIGHT_method1 :^method -> num`--), fixity=Prefix},
+               func= (--`HEIGHT_method1 :^method -> num`--), fixity=NONE},
               {def_name="FV_obj_def", fname="FV_obj",
-               func= (--`FV_obj1 :^obj -> var -> bool`--), fixity=Prefix},
+               func= (--`FV_obj1 :^obj -> var -> bool`--), fixity=NONE},
               {def_name="FV_dict_def", fname="FV_dict",
-               func= (--`FV_dict1 :^dict -> var -> bool`--), fixity=Prefix},
+               func= (--`FV_dict1 :^dict -> var -> bool`--), fixity=NONE},
               {def_name="FV_entry_def", fname="FV_entry",
-               func= (--`FV_entry1 :^entry -> var -> bool`--), fixity=Prefix},
+               func= (--`FV_entry1 :^entry -> var -> bool`--), fixity=NONE},
               {def_name="FV_method_def", fname="FV_method",
-               func= (--`FV_method1 :^method -> var -> bool`--),fixity=Prefix},
+               func= (--`FV_method1 :^method -> var -> bool`--),fixity=NONE},
               {def_name="SUB_def", fname="SUB",
-               func= (--`SUB1 :^subs -> var -> ^obj`--), fixity=Prefix},
+               func= (--`SUB1 :^subs -> var -> ^obj`--), fixity=NONE},
               {def_name="FV_subst_def", fname="FV_subst",
                func= (--`FV_subst1 :^subs -> (var -> bool) -> var -> bool`--),
-               fixity=Prefix},
+               fixity=NONE},
               {def_name="SUBo_def", fname="SUBo",
                func= (--`SUB1o :^obj -> ^subs -> ^obj`--),
-               fixity=Infix(NONASSOC,150)},
+               fixity=SOME(Infix(NONASSOC,150))},
               {def_name="SUBd_def", fname="SUBd",
                func= (--`SUB1d :^dict -> ^subs -> ^dict`--),
-               fixity=Infix(NONASSOC,150)},
+               fixity=SOME(Infix(NONASSOC,150))},
               {def_name="SUBe_def", fname="SUBe",
                func= (--`SUB1e :^entry -> ^subs -> ^entry`--),
-               fixity=Infix(NONASSOC,150)},
+               fixity=SOME(Infix(NONASSOC,150))},
               {def_name="SUBm_def", fname="SUBm",
                func= (--`SUB1m :^method -> ^subs -> ^method`--),
-               fixity=Infix(NONASSOC,150)},
+               fixity=SOME(Infix(NONASSOC,150))},
               {def_name="vsubst_def", fname="/",
                func= (--`$// :var list -> var list -> ^subs`--),
-               fixity=Infix(NONASSOC,150)},
+               fixity=SOME(Infix(NONASSOC,150))},
               {def_name="obj_0_def", fname="obj_0",
-               func= (--`obj1_0`--), fixity=Prefix},
+               func= (--`obj1_0`--), fixity=NONE},
               {def_name="method_0_def", fname="method_0",
-               func= (--`method1_0`--), fixity=Prefix},
+               func= (--`method1_0`--), fixity=NONE},
               {def_name="invoke_method_def", fname="invoke_method",
-               func= (--`invoke_method1`--), fixity=Prefix},
+               func= (--`invoke_method1`--), fixity=NONE},
               {def_name="invoke_dict_def", fname="invoke_dict",
-               func= (--`invoke_dict1`--), fixity=Prefix},
+               func= (--`invoke_dict1`--), fixity=NONE},
               {def_name="invoke_def", fname="invoke",
-               func= (--`invoke1`--), fixity=Prefix},
+               func= (--`invoke1`--), fixity=NONE},
               {def_name="update_dict_def", fname="update_dict",
-               func= (--`update_dict1`--), fixity=Prefix},
+               func= (--`update_dict1`--), fixity=NONE},
               {def_name="update_def", fname="update",
-               func= (--`update1`--), fixity=Prefix},
+               func= (--`update1`--), fixity=NONE},
               {def_name="subst_eq_def", fname="subst_eq",
                func= (--`ALPHA_subst:(var -> bool) ->^subs ->^subs -> bool`--),
-               fixity=Prefix}
+               fixity=NONE}
              ];
 
 

Modified: HOL/src/quotient/examples/sigma/more_setScript.sml
===================================================================
--- HOL/src/quotient/examples/sigma/more_setScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/quotient/examples/sigma/more_setScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -520,7 +520,7 @@
 val IN_UNION_SET =
     let val th1 = CONV_RULE SKOLEM_CONV UNION_SET_EXISTS in
     new_specification{name="IN_UNION_SET",
-                      consts=[{const_name="UNION_SET",fixity=Prefix}],
+                      consts=[{const_name="UNION_SET",fixity=NONE}],
                       sat_thm=th1}
     end
 end;

Modified: HOL/src/quotient/examples/sigma/variableScript.sml
===================================================================
--- HOL/src/quotient/examples/sigma/variableScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/quotient/examples/sigma/variableScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -372,7 +372,7 @@
     let val th1 = CONV_RULE SKOLEM_CONV variant_EXISTS in
        new_specification
          {name    = "variant",
-          consts  = [{const_name = "variant", fixity = Prefix (*700*)}],
+          consts  = [{const_name = "variant", fixity = NONE (*700*)}],
           sat_thm = th1}
     end
 end;

Modified: HOL/src/quotient/src/quotient.sig
===================================================================
--- HOL/src/quotient/src/quotient.sig	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/quotient/src/quotient.sig	2011-06-22 05:10:03 UTC (rev 9135)
@@ -223,7 +223,7 @@
         {def_name : string,         (* name to store the definition under *)
          fname : string,            (* name of new function *)
          func : Term.term,          (* old function, to be lifted *)
-         fixity : Parse.fixity} ->  (* fixity of new function *)
+         fixity : Parse.fixity option} ->  (* fixity of new function *)
         Thm.thm                     (* definition of a new lifted function *)
 
 
@@ -361,7 +361,7 @@
          defs: {def_name:string,            (* name of stored definition *)
                 fname:string,               (* name of new lifted function *)
                 func:Term.term,             (* old function to be lifted *)
-                fixity: Parse.fixity} list, (* fixity of new function *)
+                fixity: Parse.fixity option} list, (* fixity of new function *)
          tyop_equivs: Thm.thm list,  (* conditional equiv ths for type ops *)
          tyop_quotients: Thm.thm list,(*conditional quotient ths for type ops*)
          tyop_simps: Thm.thm list, (* rel/map simplification ths for type ops*)
@@ -380,7 +380,7 @@
          defs: {def_name:string,            (* name of stored definition *)
                 fname:string,               (* name of new lifted function *)
                 func:Term.term,             (* old function to be lifted *)
-                fixity: Parse.fixity} list, (* fixity of new function *)
+                fixity: Parse.fixity option} list, (* fixity of new function *)
          tyop_equivs: Thm.thm list,  (* conditional equiv ths for type ops *)
          tyop_quotients: Thm.thm list,(*conditional quotient ths for type ops*)
          tyop_simps: Thm.thm list, (* rel/map simplification ths for type ops*)
@@ -399,7 +399,7 @@
          defs: {def_name:string,            (* name of stored definition *)
                 fname:string,               (* name of new lifted function *)
                 func:Term.term,             (* old function to be lifted *)
-                fixity: Parse.fixity} list, (* fixity of new function *)
+                fixity: Parse.fixity option} list, (* fixity of new function *)
          tyop_equivs: Thm.thm list,  (* conditional equiv ths for type ops *)
          tyop_quotients: Thm.thm list,(*conditional quotient ths for type ops*)
          tyop_simps: Thm.thm list, (* rel/map simplification ths for type ops*)
@@ -418,7 +418,7 @@
          defs: {def_name:string,            (* name of stored definition *)
                 fname:string,               (* name of new lifted function *)
                 func:Term.term,             (* old function to be lifted *)
-                fixity: Parse.fixity} list, (* fixity of new function *)
+                fixity: Parse.fixity option} list, (* fixity of new function *)
          tyop_equivs: Thm.thm list,  (* conditional equiv ths for type ops *)
          tyop_quotients: Thm.thm list,(*conditional quotient ths for type ops*)
          tyop_simps: Thm.thm list, (* rel/map simplification ths for type ops*)
@@ -440,7 +440,7 @@
          defs: {def_name:string,            (* name of stored definition *)
                 fname:string,               (* name of new lifted function *)
                 func:Term.term,             (* old function to be lifted *)
-                fixity: Parse.fixity} list, (* fixity of new function *)
+                fixity: Parse.fixity option} list, (* fixity of new function *)
          respects : Thm.thm list,    (* old functions respect equivalence *)
          old_thms : Thm.thm list} -> (* theorems of old fns to be lifted *)
         Thm.thm list                 (* new lifted theorems *)
@@ -453,7 +453,7 @@
          defs: {def_name:string,            (* name of stored definition *)
                 fname:string,               (* name of new lifted function *)
                 func:Term.term,             (* old function to be lifted *)
-                fixity: Parse.fixity} list, (* fixity of new function *)
+                fixity: Parse.fixity option} list, (* fixity of new function *)
          respects : Thm.thm list} ->   (* old functions respect equivalence *)
         (Thm.thm -> Thm.thm)          (* rule for lifting theorems *)
 
@@ -465,7 +465,7 @@
          defs: {def_name:string,            (* name of stored definition *)
                 fname:string,               (* name of new lifted function *)
                 func:Term.term,             (* old function to be lifted *)
-                fixity: Parse.fixity} list, (* fixity of new function *)
+                fixity: Parse.fixity option} list, (* fixity of new function *)
          welldefs : Thm.thm list,    (* old functions respect equivalence *)
          old_thms : Thm.thm list} -> (* theorems of old fns to be lifted *)
         Thm.thm list                 (* definitions of new lifted functions *)

Modified: HOL/src/quotient/src/quotient.sml
===================================================================
--- HOL/src/quotient/src/quotient.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/quotient/src/quotient.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -1207,11 +1207,11 @@
 
 (*
 structure Parse:
-datatype fixity = RF of term_grammar.rule_fixity | Prefix | Binder
+datatype fixity = RF of term_grammar.rule_fixity | Binder
 
 structure term_grammar:
 datatype rule_fixity =
-  Infix of associativity * int | Closefix | Suffix of int | TruePrefix of int
+  Infix of associativity * int | Closefix | Suffix of int | Prefix of int
 
 structure HOLgrammars :
 datatype associativity = LEFT | RIGHT | NONASSOC
@@ -1516,32 +1516,32 @@
 
 (* The following notes are to explain the treatment of fixities:
 structure Parse:
-datatype fixity = RF of term_grammar.rule_fixity | Prefix | Binder
+datatype fixity = RF of term_grammar.rule_fixity | Binder
 
 structure term_grammar:
 datatype rule_fixity =
-  Infix of associativity * int | Closefix | Suffix of int | TruePrefix of int
+  Infix of associativity * int | Closefix | Suffix of int | Prefix of int
 
 structure HOLgrammars :
 datatype associativity = LEFT | RIGHT | NONASSOC
 *)
 
             case fixity of
-              Prefix =>
+              NONE =>
                     new_definition(def_name, def)
-            | Binder =>
+            | SOME Binder =>
                     new_binder_definition(def_name, def)
-            | RF rule_fixity =>
+            | SOME (RF rule_fixity) =>
                (case rule_fixity of
                   term_grammar.Infix (associativity, priority) =>
                     Definition.new_definition(def_name, def)
                      before
                     Parse.add_infix(nam, priority, associativity)
-                | term_grammar.TruePrefix priority =>
+                | term_grammar.Prefix priority =>
                     Definition.new_definition(def_name, def)
                      before
                     Parse.add_rule{term_name=nam,
-                                   fixity=TruePrefix priority,
+                                   fixity=Prefix priority,
                                    pp_elements=[TOK nam],
                                    paren_style=OnlyIfNecessary,
                                    block_style=(AroundEachPhrase,

Modified: HOL/src/quotient/src/selftest.sml
===================================================================
--- HOL/src/quotient/src/selftest.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/quotient/src/selftest.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -16,7 +16,7 @@
 fun mk_def t = let
   val s = "l" ^ term_to_string t
 in
-  {def_name = s ^ "_def", fixity = Prefix, fname = s, func = t}
+  {def_name = s ^ "_def", fixity = NONE, fname = s, func = t}
 end
 
 val thms = define_equivalence_type {

Modified: HOL/src/real/hratScript.sml
===================================================================
--- HOL/src/real/hratScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/real/hratScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -294,15 +294,15 @@
     {name = "hrat",
      equiv = TRAT_EQ_EQUIV, defs =
      [{def_name="hrat_1",   fname="hrat_1",
-       func=Term`trat_1`, fixity=Prefix},
+       func=Term`trat_1`, fixity=NONE},
       {def_name="hrat_inv", fname="hrat_inv",
-       func=Term`trat_inv`, fixity=Prefix},
+       func=Term`trat_inv`, fixity=NONE},
       {def_name="hrat_add", fname="hrat_add",
-       func=Term`$trat_add`, fixity=Infixl 500},
+       func=Term`$trat_add`, fixity=SOME(Infixl 500)},
       {def_name="hrat_mul", fname="hrat_mul",
-       func=Term`$trat_mul`, fixity=Infixl 600},
+       func=Term`$trat_mul`, fixity=SOME(Infixl 600)},
       {def_name="hrat_sucint", fname="hrat_sucint",
-       func=Term`trat_sucint`, fixity=Prefix}],
+       func=Term`trat_sucint`, fixity=NONE}],
      welldefs = [TRAT_INV_WELLDEFINED, TRAT_ADD_WELLDEFINED2,
                  TRAT_MUL_WELLDEFINED2],
      old_thms = [TRAT_ADD_SYM, TRAT_ADD_ASSOC, TRAT_MUL_SYM, TRAT_MUL_ASSOC,

Modified: HOL/src/real/realaxScript.sml
===================================================================
--- HOL/src/real/realaxScript.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/real/realaxScript.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -539,15 +539,15 @@
   quotient.define_equivalence_type
    {name = "real",
     equiv = TREAL_EQ_EQUIV,
-    defs = [mk_def("real_0",   Term`treal_0`,   "real_0", Prefix),
-            mk_def("real_1",   Term`treal_1`,   "real_1", Prefix),
-            mk_def("real_neg", Term`treal_neg`, "real_neg", Prefix),
-            mk_def("real_inv", Term`treal_inv`, "inv", Prefix),
-            mk_def("real_add", Term`$treal_add`, "real_add", Infixl 500),
-            mk_def("real_mul",  Term`$treal_mul`, "real_mul", Infixl 600),
-            mk_def("real_lt",  Term`$treal_lt`,  "real_lt",  Prefix),
-            mk_def("real_of_hreal",Term`$treal_of_hreal`, "real_of_hreal",Prefix),
-            mk_def("hreal_of_real", Term`$hreal_of_treal`,"hreal_of_real",Prefix)],
+    defs = [mk_def("real_0",   Term`treal_0`,   "real_0", NONE),
+            mk_def("real_1",   Term`treal_1`,   "real_1", NONE),
+            mk_def("real_neg", Term`treal_neg`, "real_neg", NONE),
+            mk_def("real_inv", Term`treal_inv`, "inv", NONE),
+            mk_def("real_add", Term`$treal_add`, "real_add", SOME(Infixl 500)),
+            mk_def("real_mul",  Term`$treal_mul`, "real_mul", SOME(Infixl 600)),
+            mk_def("real_lt",  Term`$treal_lt`,  "real_lt",  NONE),
+            mk_def("real_of_hreal",Term`$treal_of_hreal`, "real_of_hreal",NONE),
+            mk_def("hreal_of_real", Term`$hreal_of_treal`,"hreal_of_real",NONE)],
     welldefs = [TREAL_NEG_WELLDEF, TREAL_INV_WELLDEF, TREAL_LT_WELLDEF,
                 TREAL_ADD_WELLDEF, TREAL_MUL_WELLDEF, TREAL_BIJ_WELLDEF],
     old_thms = ([TREAL_10]

Modified: HOL/src/res_quan/src/res_quanTools.sml
===================================================================
--- HOL/src/res_quan/src/res_quanTools.sml	2011-06-22 05:06:48 UTC (rev 9134)
+++ HOL/src/res_quan/src/res_quanTools.sml	2011-06-22 05:10:03 UTC (rev 9135)
@@ -571,14 +571,14 @@
                      sat_thm = def_thm}
 end;
 
-val new_resq_definition =  new_gen_resq_definition Prefix;
+val new_resq_definition =  new_gen_resq_definition NONE;
 
 fun new_infixl_resq_definition (name,tm,fix) =
-    new_gen_resq_definition (Infixl fix) (name,tm);
+    new_gen_resq_definition (SOME (Infixl fix)) (name,tm);
 fun new_infixr_resq_definition (name,tm,fix) =
-    new_gen_resq_definition (Infixr fix) (name,tm);
+    new_gen_resq_definition (SOME (Infixr fix)) (name,tm);
 
-val new_binder_resq_definition =  new_gen_resq_definition Binder;
+val new_binder_resq_definition =  new_gen_resq_definition (SOME Binder);
 
 (* --------------------------------------------------------------------- *)
 (* Some restricted quantifier functions using term quotations            *)


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 9160
          http://hol.svn.sourceforge.net/hol/?rev=9160&view=rev
Author:   michaeln
Date:     2011-07-18 06:32:12 +0000 (Mon, 18 Jul 2011)

Log Message:
-----------
Set svn:ignore property in a few new places.

Property Changed:
----------------
    HOL/examples/unification/triangular/
    HOL/examples/unification/triangular/first-order/
    HOL/examples/unification/triangular/nominal/
    HOL/src/complex/
    HOL/src/string/theorytesting/


Property changes on: HOL/examples/unification/triangular
___________________________________________________________________
Added: svn:ignore
   + *.uo
*.ui
*Theory.sig
*Theory.sml
selftest.exe
.HOLMK



Property changes on: HOL/examples/unification/triangular/first-order
___________________________________________________________________
Added: svn:ignore
   + *.uo
*.ui
*Theory.sig
*Theory.sml
selftest.exe
.HOLMK



Property changes on: HOL/examples/unification/triangular/nominal
___________________________________________________________________
Added: svn:ignore
   + *.uo
*.ui
*Theory.sig
*Theory.sml
selftest.exe
.HOLMK



Property changes on: HOL/src/complex
___________________________________________________________________
Added: svn:ignore
   + *.uo
*.ui
*Theory.sig
*Theory.sml
selftest.exe
.HOLMK



Property changes on: HOL/src/string/theorytesting
___________________________________________________________________
Added: svn:ignore
   + *.uo
*.ui
*Theory.sig
*Theory.sml
selftest.exe
.HOLMK



This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 9163
          http://hol.svn.sourceforge.net/hol/?rev=9163&view=rev
Author:   michaeln
Date:     2011-07-24 06:19:15 +0000 (Sun, 24 Jul 2011)

Log Message:
-----------
Terms and labelled terms now derived from generic terms.

This is a big change that points to the implementation of a complete
nominal datatype package.  The use of generic terms means that we only
need to do one hairy quotient, and one hairy derivation of a recursion
principle.

The recursion principle in question features a new "FCB" (one of the
side-conditions that need to be proved in order to get a recursive
function admitted).  Though I think it's better, it can be a little
fiddlier to prove.  It's also stronger, so in theory, there may be
reasonable functions that the new FCB rejects. It should certainly be
possible to automate the bulk of the new fiddly proofs.

Modified Paths:
--------------
    HOL/examples/computability/lambda/churchDBScript.sml
    HOL/examples/computability/lambda/churchboolScript.sml
    HOL/examples/computability/lambda/churchlistScript.sml
    HOL/examples/computability/lambda/churchnumScript.sml
    HOL/examples/lambda/barendregt/chap11_1Script.sml
    HOL/examples/lambda/barendregt/chap2Script.sml
    HOL/examples/lambda/barendregt/labelledTermsScript.sml
    HOL/examples/lambda/barendregt/normal_orderScript.sml
    HOL/examples/lambda/barendregt/standardisationScript.sml
    HOL/examples/lambda/basics/appFOLDLScript.sml
    HOL/examples/lambda/basics/binderLib.sig
    HOL/examples/lambda/basics/binderLib.sml
    HOL/examples/lambda/basics/generic_termsScript.sml
    HOL/examples/lambda/basics/nomsetScript.sml
    HOL/examples/lambda/basics/termScript.sml
    HOL/examples/lambda/basics/termSyntax.sml
    HOL/src/list/src/listScript.sml
    HOL/src/one/oneScript.sml

Added Paths:
-----------
    HOL/examples/lambda/basics/nomdatatype.sig
    HOL/examples/lambda/basics/nomdatatype.sml

Removed Paths:
-------------
    HOL/examples/lambda/barendregt/preltermScript.sml
    HOL/examples/lambda/basics/pretermScript.sml

Modified: HOL/examples/computability/lambda/churchDBScript.sml
===================================================================
--- HOL/examples/computability/lambda/churchDBScript.sml	2011-07-18 06:39:04 UTC (rev 9162)
+++ HOL/examples/computability/lambda/churchDBScript.sml	2011-07-24 06:19:15 UTC (rev 9163)
@@ -805,7 +805,7 @@
 
 val cichurch_behaviour = store_thm(
   "cichurch_behaviour",
-  ``cichurch @@ church n -n->* cDB (fromTerm (FUNPOW ((@@) (VAR (n2s 0))) n
+  ``cichurch @@ church n -n->* cDB (fromTerm (FUNPOW (APP (VAR (n2s 0))) n
                                                      (VAR (n2s 1))))``,
   SIMP_TAC (bsrw_ss()) [cichurch_def, cdV_behaviour] THEN
   Induct_on `n` THEN
@@ -830,7 +830,7 @@
 
 val fromTerm_funpow_app = store_thm(
   "fromTerm_funpow_app",
-  ``fromTerm (FUNPOW ((@@) f) n x) =
+  ``fromTerm (FUNPOW (APP f) n x) =
       FUNPOW (dAPP (fromTerm f)) n (fromTerm x)``,
   Induct_on `n` THEN SRW_TAC [][FUNPOW_SUC]);
 

Modified: HOL/examples/computability/lambda/churchboolScript.sml
===================================================================
--- HOL/examples/computability/lambda/churchboolScript.sml	2011-07-18 06:39:04 UTC (rev 9162)
+++ HOL/examples/computability/lambda/churchboolScript.sml	2011-07-24 06:19:15 UTC (rev 9163)
@@ -15,6 +15,7 @@
 val _ = remove_ovl_mapping "LAM" {Name="LAM", Thy="labelledTerms"}
 val _ = remove_ovl_mapping "FV"  {Name="FV",  Thy="labelledTerms"}
 val _ = remove_ovl_mapping "VAR" {Name="VAR", Thy="labelledTerms"}
+val _ = remove_ovl_mapping "APP"  {Name="APP", Thy="labelledTerms"}
 val _ = remove_ovl_mapping "@@"  {Name="APP", Thy="labelledTerms"}
 
 fun Store_thm(n,t,tac) = store_thm(n,t,tac) before export_rewrites [n]

Modified: HOL/examples/computability/lambda/churchlistScript.sml
===================================================================
--- HOL/examples/computability/lambda/churchlistScript.sml	2011-07-18 06:39:04 UTC (rev 9162)
+++ HOL/examples/computability/lambda/churchlistScript.sml	2011-07-24 06:19:15 UTC (rev 9163)
@@ -148,19 +148,19 @@
   SRW_TAC [][cis_zero_def] THEN ASM_SIMP_TAC (whfy(srw_ss())) [] THEN
   FULL_SIMP_TAC (srw_ss()) [church_def] THEN
   Q_TAC (NEW_TAC "z") `FV N ∪ {"z"; "s"}` THEN
-  `LAM "z" (LAM "s" (FUNPOW ((@@) (VAR "s")) n (VAR "z"))) =
-   LAM z (LAM "s" (FUNPOW ((@@) (VAR "s")) n (VAR z)))`
+  `LAM "z" (LAM "s" (FUNPOW (APP (VAR "s")) n (VAR "z"))) =
+   LAM z (LAM "s" (FUNPOW (APP (VAR "s")) n (VAR z)))`
      by SRW_TAC [][LAM_eq_thm] THEN
   POP_ASSUM SUBST_ALL_TAC THEN
-  `∃N0. N -w->* LAM z N0 ∧ N0 -n->* LAM "s" (FUNPOW ((@@) (VAR "s")) n (VAR z))`
+  `∃N0. N -w->* LAM z N0 ∧ N0 -n->* LAM "s" (FUNPOW (APP (VAR "s")) n (VAR z))`
      by METIS_TAC [normstar_to_abs_wstar] THEN
   ASM_SIMP_TAC (whfy(srw_ss())) [] THEN
   Q_TAC (NEW_TAC "s") `FV N0 ∪ {"s"; z}` THEN
-  `LAM "s" (FUNPOW ((@@) (VAR "s")) n (VAR z)) =
-     LAM s (FUNPOW ((@@) (VAR s)) n (VAR z))`
+  `LAM "s" (FUNPOW (APP (VAR "s")) n (VAR z)) =
+     LAM s (FUNPOW (APP (VAR s)) n (VAR z))`
     by SRW_TAC [][LAM_eq_thm] THEN
   POP_ASSUM SUBST_ALL_TAC THEN
-  `∃N1. N0 -w->* LAM s N1 ∧ N1 -n->* FUNPOW ((@@) (VAR s)) n (VAR z)`
+  `∃N1. N0 -w->* LAM s N1 ∧ N1 -n->* FUNPOW (APP (VAR s)) n (VAR z)`
     by METIS_TAC [normstar_to_abs_wstar] THEN
   ASM_SIMP_TAC (whfy(srw_ss())) [] THEN
   Cases_on `n` THEN
@@ -391,7 +391,7 @@
 
 val cmap_cvlist = store_thm(
   "cmap_cvlist",
-  ``cmap @@ f @@ cvlist l == cvlist (MAP ((@@) f) l)``,
+  ``cmap @@ f @@ cvlist l == cvlist (MAP (APP f) l)``,
   Induct_on `l` THEN
   ASM_SIMP_TAC (bsrw_ss()) [cmap_behaviour, Cong cvcons_cong]);
 

Modified: HOL/examples/computability/lambda/churchnumScript.sml
===================================================================
--- HOL/examples/computability/lambda/churchnumScript.sml	2011-07-18 06:39:04 UTC (rev 9162)
+++ HOL/examples/computability/lambda/churchnumScript.sml	2011-07-24 06:19:15 UTC (rev 9163)
@@ -17,14 +17,14 @@
 val _ = set_trace "Unicode" 1
 
 val church_def = Define`
-  church n = LAM "z" (LAM "s" (FUNPOW ((@@) (VAR "s")) n (VAR "z")))
+  church n = LAM "z" (LAM "s" (FUNPOW (APP (VAR "s")) n (VAR "z")))
 `
 
 val FUNPOW_SUC = arithmeticTheory.FUNPOW_SUC
 
 val size_funpow = store_thm(
   "size_funpow",
-  ``size (FUNPOW ((@@) f) n x) = (size f + 1) * n + size x``,
+  ``size (FUNPOW (APP f) n x) = (size f + 1) * n + size x``,
   Induct_on `n` THEN
   SRW_TAC [ARITH_ss][FUNPOW_SUC, arithmeticTheory.LEFT_ADD_DISTRIB,
                      arithmeticTheory.MULT_CLAUSES]);
@@ -69,7 +69,7 @@
   SRW_TAC [][] THENL [
     SRW_TAC [CONJ_ss] [EXTENSION],
     Q_TAC SUFF_TAC
-          `FV (FUNPOW ((@@) (VAR "s")) (SUC m) (VAR "z")) = {"s"; "z"}`
+          `FV (FUNPOW (APP (VAR "s")) (SUC m) (VAR "z")) = {"s"; "z"}`
           THEN1 SRW_TAC [CONJ_ss][pred_setTheory.EXTENSION] THEN
     Induct_on `m` THEN SRW_TAC [][] THENL [
       SRW_TAC [][EXTENSION],
@@ -81,7 +81,7 @@
 
 val is_church_def = Define`
   is_church t =
-    ∃f z n. f ≠ z ∧ (t = LAM z (LAM f (FUNPOW ((@@) (VAR f)) n (VAR z))))
+    ∃f z n. f ≠ z ∧ (t = LAM z (LAM f (FUNPOW (APP (VAR f)) n (VAR z))))
 `;
 
 
@@ -108,28 +108,28 @@
 
 val tpm_funpow_app = store_thm(
   "tpm_funpow_app",
-  ``tpm pi (FUNPOW ($@@ f) n x) = FUNPOW ($@@ (tpm pi f)) n (tpm pi x)``,
+  ``tpm pi (FUNPOW (APP f) n x) = FUNPOW (APP (tpm pi f)) n (tpm pi x)``,
   Induct_on `n` THEN SRW_TAC [][FUNPOW_SUC]);
 val _  = export_rewrites ["tpm_funpow_app"]
 
 val FV_funpow_app = store_thm(
   "FV_funpow_app",
-  ``FV (FUNPOW ($@@ f) n x) ⊆ FV f ∪ FV x``,
+  ``FV (FUNPOW (APP f) n x) ⊆ FV f ∪ FV x``,
   Induct_on `n` THEN SRW_TAC [][FUNPOW_SUC]);
 
 val FV_funpow_app_I = store_thm(
   "FV_funpow_app_I",
-  ``v ∈ FV x ⇒ v ∈ FV (FUNPOW ((@@) f) n x)``,
+  ``v ∈ FV x ⇒ v ∈ FV (FUNPOW (APP f) n x)``,
   Induct_on `n` THEN SRW_TAC [][FUNPOW_SUC]);
 
 val FV_funpow_app_E = store_thm(
   "FV_funpow_app_E",
-  ``v ∈ FV (FUNPOW ((@@) f) n x) ⇒ v ∈ FV f ∨ v ∈ FV x``,
+  ``v ∈ FV (FUNPOW (APP f) n x) ⇒ v ∈ FV f ∨ v ∈ FV x``,
   MATCH_ACCEPT_TAC (REWRITE_RULE [IN_UNION, SUBSET_DEF] FV_funpow_app));
 
 val fresh_funpow_app_I = store_thm(
   "fresh_funpow_app_I",
-  ``v ∉ FV f ∧ v ∉ FV x ⇒ v ∉ FV (FUNPOW ((@@) f) n x)``,
+  ``v ∉ FV f ∧ v ∉ FV x ⇒ v ∉ FV (FUNPOW (APP f) n x)``,
   METIS_TAC [FV_funpow_app_E]);
 val _ = export_rewrites ["fresh_funpow_app_I"]
 
@@ -156,7 +156,7 @@
 
 val SUB_funpow_app = store_thm(
   "SUB_funpow_app",
-  ``[M/v] (FUNPOW ($@@ f) n x) = FUNPOW ($@@ ([M/v]f)) n ([M/v]x)``,
+  ``[M:term/v] (FUNPOW (APP f) n x) = FUNPOW (APP ([M/v]f)) n ([M/v]x)``,
   Induct_on `n` THEN SRW_TAC [][FUNPOW_SUC]);
 val _ = export_rewrites ["SUB_funpow_app"]
 

Modified: HOL/examples/lambda/barendregt/chap11_1Script.sml
===================================================================
--- HOL/examples/lambda/barendregt/chap11_1Script.sml	2011-07-18 06:39:04 UTC (rev 9162)
+++ HOL/examples/lambda/barendregt/chap11_1Script.sml	2011-07-24 06:19:15 UTC (rev 9163)
@@ -10,90 +10,18 @@
 
 fun Store_Thm(n,t,tac) = store_thm(n,t,tac) before export_rewrites [n]
 
-val lterm_CASES = store_thm(
-  "lterm_CASES",
-  ``!M. (?s. M = VAR s) \/ (?N P. M = N @@ P) \/
-        (?v N. M = LAM v N) \/ (?v n N P. M = LAMi n v N P)``,
-  HO_MATCH_MP_TAC simple_lterm_induction THEN
-  SRW_TAC [][] THEN METIS_TAC []);
-
-
-(* definition of lsize - testing recursion code *)
-val lsize_supp_lemma = prove(
-  ``supp (fnpm (pairpm (K I) ltpm) (pairpm (K I) ltpm))
-         (\aN. f (FST aN), LAMi n v M (SND aN)) =
-    FV M DELETE v``,
-  Q.MATCH_ABBREV_TAC `supp p g = Set` THEN
-  `support p g Set`
-     by (UNABBREV_ALL_TAC THEN
-         SRW_TAC [][support_def, fnpm_def, FUN_EQ_THM] THEN
-         SRW_TAC [][lLAMi_eq_thm, basic_swapTheory.swapstr_def] THEN
-         SRW_TAC [][ltpm_fresh] THEN
-         SRW_TAC [boolSimps.CONJ_ss][ltpm_flip_args]) THEN
-  UNABBREV_ALL_TAC THEN
-  MATCH_MP_TAC supp_unique_apart THEN
-  SRW_TAC [][] THEN
-  SRW_TAC [][fnpm_def, FUN_EQ_THM, lLAMi_eq_thm] THENL [
-    METIS_TAC [ltpm_apart, ltpm_flip_args],
-    Cases_on `b = v` THEN SRW_TAC [][]
-  ])
-
-val (lsize_thm,_) = define_recursive_term_function'
-  (SIMP_CONV (srw_ss()) [lsize_supp_lemma])
-  `(lsize (VAR s) = 1) /\
-   (lsize (M @@ N) = lsize M + lsize N + 1) /\
-   (lsize (LAM v M) = lsize M + 1) /\
-   (lsize (LAMi n v M N) = lsize M + lsize N + 2)`
-
 (* ----------------------------------------------------------------------
     phi function for reducing all labelled redexes
    ---------------------------------------------------------------------- *)
 
-val phisupp_lemma = prove(
-  ``supp (fnpm (pairpm tpm ltpm) (pairpm tpm ltpm))
-         (\u. ([FST u/v] M1, LAMi n v M2 (SND u))) =
-    (FV M1 UNION FV M2) DELETE v``,
-  MATCH_MP_TAC supp_unique_apart THEN
-  SRW_TAC [][FUN_EQ_THM, fnpm_def, lLAMi_eq_thm, tpm_subst] THEN
-  SRW_TAC [][ONCE_REWRITE_RULE [ltpm_flip_args] ltpm_apart,
-             basic_swapTheory.swapstr_thm]
-  THENL [
-    SRW_TAC [][support_def, fnpm_def, FUN_EQ_THM, tpm_subst,
-               tpm_fresh, lLAMi_eq_thm] THEN
-    SRW_TAC [][tpm_fresh, ltpm_fresh]
-    THENL [
-      Cases_on `x = v` THEN SRW_TAC [][tpm_fresh, lemma14b] THEN
-      Cases_on `y = v` THEN SRW_TAC [][tpm_fresh, lemma14b],
-      Cases_on `x = v` THEN SRW_TAC [][ltpm_fresh] THEN
-      Cases_on `y = v` THEN SRW_TAC [][ltpm_fresh],
-      Cases_on `x = v` THEN SRW_TAC [][] THEN
-      SRW_TAC [][fresh_tpm_subst, lemma15a],
-      SRW_TAC [boolSimps.CONJ_ss][],
-      `tpm [(v,y)] M1 = [VAR y/v] M1`
-         by METIS_TAC [fresh_tpm_subst, tpm_flip_args] THEN
-      SRW_TAC [][lemma15a],
-      SRW_TAC [boolSimps.CONJ_ss][ltpm_flip_args]
-    ],
-    Cases_on `b = v` THEN SRW_TAC [][] THENL [
-      Q.EXISTS_TAC `(VAR a, dontcare)` THEN SRW_TAC [][] THEN
-      DISJ1_TAC THEN STRIP_TAC THEN
-      POP_ASSUM (MP_TAC o Q.AP_TERM `FV : term -> string set`) THEN
-      SRW_TAC [][EXTENSION, FV_SUB] THEN
-      Q.EXISTS_TAC `a` THEN SRW_TAC [][],
-      Q.EXISTS_TAC `(VAR v, dontcare)` THEN SRW_TAC [][] THEN
-      METIS_TAC [tpm_apart, tpm_flip_args]
-    ],
-    Q.EXISTS_TAC `(VAR a, dontcare)` THEN SRW_TAC [][] THEN
-    DISJ1_TAC THEN STRIP_TAC THEN
-    POP_ASSUM (MP_TAC o Q.AP_TERM `FV : term -> string set`) THEN
-    SRW_TAC [][EXTENSION, FV_SUB] THEN
-    Q.EXISTS_TAC `b` THEN SRW_TAC [][],
-    Cases_on `b = v` THEN SRW_TAC [][]
-  ])
+val NOT_IN_SUB1_I = prove(
+  ``∀M:term. v ∉ FV N ==> v ∉ FV ([N/v]M)``,
+  HO_MATCH_MP_TAC nc_INDUCTION2 THEN Q.EXISTS_TAC `FV N ∪ {v}` THEN
+  SRW_TAC [][SUB_VAR]);
 
 val (phi_thm, _) =
     define_recursive_term_function'
-      (SIMP_CONV (srw_ss()) [tpm_subst, phisupp_lemma])
+      (SIMP_CONV (srw_ss()) [tpm_subst, NOT_IN_SUB1_I])
       `(phi (VAR s) = VAR s : term) /\
        (phi (M @@ N) = phi M @@ phi N) /\
        (phi (LAM v M) = LAM v (phi M)) /\
@@ -110,6 +38,12 @@
     FULL_SIMP_TAC (srw_ss()) [FV_SUB] THEN METIS_TAC [IN_UNION, IN_DELETE]
   ]);
 
+val NOT_IN_lSUB_I = Store_Thm(
+  "NOT_IN_lSUB_I",
+  ``∀M:lterm. v ∉ FV N ∧ v ≠ u ∧ v ∉ FV M ==> v ∉ FV ([N/u]M)``,
+  HO_MATCH_MP_TAC lterm_bvc_induction THEN Q.EXISTS_TAC `FV N ∪ {u;v}` THEN
+  SRW_TAC [][lSUB_VAR]);
+
 val phi_vsubst_commutes = store_thm(
   "phi_vsubst_commutes",
   ``!M. phi ([VAR v/u] M) = [VAR v/u] (phi M)``,
@@ -138,15 +72,12 @@
     SRW_TAC [][LAM_eq_thm, ONCE_REWRITE_RULE [tpm_flip_args] tpm_apart] THEN
     Cases_on `b = v` THEN SRW_TAC [][],
     SRW_TAC [][LAM_eq_thm, ONCE_REWRITE_RULE [tpm_flip_args] tpm_apart],
-    SRW_TAC [][lLAMi_eq_thm,
-               ONCE_REWRITE_RULE [ltpm_flip_args] ltpm_apart] THEN
+    SRW_TAC [][lLAMi_eq_thm, ltpm_apart] THEN
     Cases_on `b = v` THEN SRW_TAC [][],
-    SRW_TAC [][lLAMi_eq_thm,
-               ONCE_REWRITE_RULE [ltpm_flip_args] ltpm_apart]
+    SRW_TAC [][lLAMi_eq_thm, ltpm_apart]
   ]);
 
-val (strip_label_thm,_) = define_recursive_term_function'
-  (SIMP_CONV (srw_ss()) [supp_lamax_app])
+val (strip_label_thm,_) = define_recursive_term_function
   `(strip_label (VAR s) = VAR s : term) /\
    (strip_label (M @@ N) = strip_label M @@ strip_label N) /\
    (strip_label (LAM v M) = LAM v (strip_label M)) /\

Modified: HOL/examples/lambda/barendregt/chap2Script.sml
===================================================================
--- HOL/examples/lambda/barendregt/chap2Script.sml	2011-07-18 06:39:04 UTC (rev 9162)
+++ HOL/examples/lambda/barendregt/chap2Script.sml	2011-07-24 06:19:15 UTC (rev 9163)
@@ -40,7 +40,7 @@
 
 val leftctxt = store_thm(
   "leftctxt",
-  ``!z. one_hole_context ($@@ z)``,
+  ``!z. one_hole_context (APP z)``,
   Q_TAC SUFF_TAC `!z. one_hole_context (\t. z @@ (\x. x) t)` THEN1
      SRW_TAC [boolSimps.ETA_ss][] THEN
   SRW_TAC [][one_hole_context_rules]);
@@ -593,12 +593,10 @@
   SRW_TAC [][SUB_THM, ISUB_LAM]);
 val _ = export_rewrites ["extra_LAM_DISJOINT"]
 
-val swap_eq_var = store_thm(
-  "swap_eq_var",
-  ``(tpm [(x,y)] t = VAR s) = (t = VAR (swapstr x y s))``,
-  Q.SPEC_THEN `t` STRUCT_CASES_TAC term_CASES THEN
-  SRW_TAC [][basic_swapTheory.swapstr_eq_left]);
-val _ = augment_srw_ss [rewrites [GSYM swap_eq_var]]
+val tpm_eq_var = prove(
+  ``(tpm pi t = VAR s) <=> (t = VAR (lswapstr pi⁻¹ s))``,
+  SRW_TAC [][tpm_eql]);
+val _ = augment_srw_ss [rewrites [tpm_eq_var]]
 
 val (enf_thm, _) = define_recursive_term_function
   `(enf (VAR s) <=> T) /\

Modified: HOL/examples/lambda/barendregt/labelledTermsScript.sml
===================================================================
--- HOL/examples/lambda/barendregt/labelledTermsScript.sml	2011-07-18 06:39:04 UTC (rev 9162)
+++ HOL/examples/lambda/barendregt/labelledTermsScript.sml	2011-07-24 06:19:15 UTC (rev 9163)
@@ -1,1032 +1,477 @@
-(* This is an -*- sml -*- file *)
-
-(* could perform quotient now *)
-
-(* First show connection with nomset concepts *)
 open HolKernel boolLib Parse bossLib BasicProvers
 open pred_setTheory
 
 open binderLib
-open basic_swapTheory nomsetTheory termTheory preltermTheory
+open basic_swapTheory nomsetTheory generic_termsTheory
+open lcsymtacs
+open nomdatatype
+open boolSimps
 
+
 val _ = new_theory "labelledTerms"
 
-fun Store_Thm(n,t,tac) = store_thm(n,t,tac) before export_rewrites [n]
-fun Save_Thm(n,th) = save_thm(n,th) before export_rewrites [n]
+fun Store_thm(n,t,tac) = store_thm(n,t,tac) before export_rewrites [n]
+fun Save_thm(n,th) = save_thm(n,th) before export_rewrites [n]
 
+val tyname = "lterm"
 
-val _ = print "Proving recursion theorem\n"
+val vp = ``(λn u: unit. n = 0)``
+val lp = ``(λn (d:unit + unit + num) tns uns.
+               (n = 0) ∧ ISL d ∧ (tns = []) ∧ (uns = [0;0]) ∨
+               (n = 0) ∧ ISR d ∧ ISL (OUTR d) ∧ (tns = [0]) ∧ (uns = []) ∨
+               (n = 0) ∧ ISR d ∧ ISR (OUTR d) ∧ (tns = [0]) ∧ (uns = [0]))``
 
-val lamf = ``lamf : string -> 'a -> 'a``
-val h = ``\a':string. ^lamf a' ((s:(string # string) list->'a)
-                                 (pi ++ [(a',a)]))``
+val {term_ABS_pseudo11, term_REP_11, genind_term_REP, genind_exists,
+     termP, absrep_id, repabs_pseudo_id, newty, term_REP_t, term_ABS_t,...} =
+    new_type_step1 tyname {vp=vp, lp = lp}
 
-val limf = ``limf : num -> string -> 'a -> 'a -> 'a``
-val i = ``\a':string.
-             ^limf n a' ((s:(string # string) list -> 'a) (pi ++ [(a',a)]))``
-val limf_pm = ``fnpm (K I : num pm) (fnpm perm_of (fnpm apm (fnpm apm apm)))``
+val _ = temp_overload_on ("termP", termP)
 
-val lamf_supp_t = ``supp (fnpm perm_of (fnpm apm apm)) ^lamf``
-val limf_supp_t = ``supp ^limf_pm ^limf``
+val [gvar,glam] = genind_rules |> SPEC_ALL |> CONJUNCTS
+val qnewty = ty_antiq newty
 
-val finite_supp = prove(
-  ``is_perm pm /\ support pm a X /\ FINITE X ==> FINITE(supp pm a)``,
-  METIS_TAC [supp_smallest, SUBSET_FINITE]);
+fun defined_const th = th |> concl |> strip_forall |> #2 |> lhs |> repeat rator
 
-val perm_fnapp = prove(
-  ``is_perm pm1 /\ is_perm pm2 ==>
-    (pm2 pi (f x) = (fnpm pm1 pm2 pi f) (pm1 pi x))``,
-  SRW_TAC [][fnpm_def, is_perm_inverse]);
+val LAM_t = mk_var("LAM", ``:string -> ^newty -> ^newty``)
+val LAM_def = new_definition(
+  "LAM_def",
+  ``^LAM_t v t = ^term_ABS_t (GLAM v (INR (INL ())) [^term_REP_t t] [])``);
+val LAM_termP = prove(
+  mk_comb(termP, LAM_def |> SPEC_ALL |> concl |> rhs |> rand),
+  match_mp_tac glam >> srw_tac [][genind_term_REP])
+val LAM_t = defined_const LAM_def
 
-val supp_fresh = prove(
-  ``is_perm pm /\ ~(x IN supp pm a) /\ ~(y IN supp pm a) ==>
-    (pm [(x,y)] a = a)``,
-  METIS_TAC [supp_supports, support_def]);
+val LAMi_t = mk_var("LAMi", ``:num -> string -> ^newty -> ^newty -> ^newty``)
+val LAMi_def = new_definition(
+  "LAMi_def",
+  ``^LAMi_t n v t1 t2 =
+      ^term_ABS_t (GLAM v (INR (INR n)) [^term_REP_t t1] [^term_REP_t t2])``);
+val LAMi_termP = prove(
+  mk_comb(termP, LAMi_def |> SPEC_ALL |> concl |> rhs |> rand),
+  match_mp_tac glam >> srw_tac [][genind_term_REP]);
+val LAMi_t = defined_const LAMi_def
 
-val supp_freshf = prove(
-  ``is_perm pm1 /\ is_perm pm2 /\
-    ~(x IN supp (fnpm pm1 pm2) f) /\ ~(y IN supp (fnpm pm1 pm2) f) ==>
-    !a. pm2 [(x,y)] (f a) = f (pm1 [(x,y)] a)``,
-  REPEAT STRIP_TAC THEN
-  `pm2 [(x,y)] (f a) = fnpm pm1 pm2 [(x,y)] f (pm1 [(x,y)] a)`
-     by SRW_TAC [][GSYM perm_fnapp] THEN
-  SRW_TAC [][supp_fresh]);
+val APP_t = mk_var("APP", ``:^newty -> ^newty -> ^newty``)
+val APP_pattern = ``GLAM v (INL ()) [] [^term_REP_t t1; ^term_REP_t t2]``
+val APP_def = new_definition(
+  "APP_def",
+  ``^APP_t t1 t2 =
+      ^term_ABS_t ^(subst [``v:string`` |-> ``ARB:string``] APP_pattern)``);
+val APP_t = defined_const APP_def
+val APP_termP = prove(
+  mk_comb(termP, APP_pattern),
+  match_mp_tac glam >> srw_tac [][genind_term_REP]);
 
-val support_freshf = prove(
-  ``is_perm pm1 /\ is_perm pm2 /\ ~(x IN A) /\ ~(y IN A) /\
-    support (fnpm pm1 pm2) f A ==>
-    !a. pm2 [(x,y)] (f a) = f (pm1 [(x,y)] a)``,
-  SRW_TAC [][support_def] THEN
-  `pm2 [(x,y)] (f a) = fnpm pm1 pm2 [(x,y)] f (pm1 [(x,y)] a)`
-     by SRW_TAC [][GSYM perm_fnapp] THEN
-  SRW_TAC [][]);
+val APP_def' = prove(
+  ``^term_ABS_t ^APP_pattern = ^APP_t t1 t2``,
+  srw_tac [][APP_def, GLAM_NIL_EQ, term_ABS_pseudo11, APP_termP]);
 
-val lamf_support_t = ``support (fnpm perm_of (fnpm apm apm)) lamf A``
-val app_support_t = ``support (fnpm apm (fnpm apm apm)) ap A``
-val var_support_t = ``support (fnpm perm_of apm) vr A``
-val limf_support_t = ``support ^limf_pm limf A``
 
-val lamf_support_fresh = UNDISCH (UNDISCH (prove(
-  ``^lamf_support_t ==> is_perm apm ==>
-    !x y v a.
-      ~(x IN A) /\ ~(y IN A) ==>
-        (apm [(x,y)] (lamf v a) = lamf (swapstr x y v) (apm [(x,y)] a))``,
-  REPEAT STRIP_TAC THEN
-  `apm [(x,y)] (lamf v a) =
-       fnpm apm apm [(x,y)] (lamf v) (apm [(x,y)] a)`
-     by SRW_TAC [][fnpm_def, is_perm_sing_inv] THEN
-  SRW_TAC [][] THEN AP_THM_TAC THEN
-  `swapstr x y v = perm_of [(x,y)] v` by SRW_TAC [][] THEN
-  POP_ASSUM SUBST1_TAC THEN MATCH_MP_TAC support_freshf THEN
-  SRW_TAC [][])))
+val VAR_t = mk_var("VAR", ``:string -> ^newty``)
+val VAR_def = new_definition(
+  "VAR_def",
+  ``^VAR_t s = ^term_ABS_t (GVAR s ())``);
+val VAR_termP = prove(
+  mk_comb(termP, VAR_def |> SPEC_ALL |> concl |> rhs |> rand),
+  match_mp_tac gvar >> srw_tac [][genind_term_REP]);
+val VAR_t = defined_const VAR_def
 
-val limf_support_fresh = UNDISCH (UNDISCH (prove(
-  ``^limf_support_t ==> is_perm apm ==>
-    !x y v n a1 a2.
-       ~(x IN A) /\ ~(y IN A) ==>
-       (apm [(x,y)] (limf n v a1 a2) =
-          limf n (swapstr x y v) (apm [(x,y)] a1) (apm [(x,y)] a2))``,
-  REPEAT STRIP_TAC THEN
-  `apm [(x,y)] (limf n v a1 a2) =
-       fnpm apm apm [(x,y)] (limf n v a1) (apm [(x,y)] a2)`
-     by SRW_TAC [][fnpm_def, is_perm_sing_inv] THEN
-  SRW_TAC [][] THEN AP_THM_TAC THEN
-  `fnpm apm apm [(x,y)] (limf n v a1) =
-       fnpm apm (fnpm apm apm) [(x,y)] (limf n v) (apm [(x,y)] a1)`
-     by SRW_TAC [][fnpm_def, is_perm_sing_inv] THEN
-  SRW_TAC [][] THEN AP_THM_TAC THEN
-  `fnpm apm (fnpm apm apm) [(x,y)] (limf n v) =
-       fnpm perm_of (fnpm apm (fnpm apm apm)) [(x,y)] (limf n)
-            (swapstr x y v)`
-     by SRW_TAC [][fnpm_def, is_perm_sing_inv] THEN
-  SRW_TAC [][] THEN AP_THM_TAC THEN
-  `fnpm perm_of (fnpm apm (fnpm apm apm)) [(x,y)] (limf n) =
-     ^limf_pm [(x,y)] limf n`
-     by SRW_TAC [][fnpm_def, is_perm_sing_inv] THEN
-  SRW_TAC [][] THEN AP_THM_TAC THEN
-  METIS_TAC [support_def])));
+(* tpm *)
+val tpm_name = "ltpm"
+val t = mk_var("lt", newty)
+val tpm_t = mk_var(tpm_name, ``:^newty pm``)
+val tpm_def = new_definition(
+  tpm_name ^ "_def",
+  ``^tpm_t pi ^t = ^term_ABS_t (gtpm pi (^term_REP_t ^t))``);
+val tpm_t = tpm_def |> SPEC_ALL |> concl |> lhs |> repeat rator
 
-val h_supp_t = ``supp (fnpm perm_of apm) ^h``
-val i_supp_t = ``supp (fnpm perm_of (fnpm apm apm)) ^i``
+val term_REP_tpm =
+    tpm_def |> SPEC_ALL |> AP_TERM term_REP_t
+             |> SIMP_RULE bool_ss [repabs_pseudo_id, genind_gtpm_eqn, genind_term_REP]
 
-val ctxt00 = ``^lamf_support_t /\ ^limf_support_t /\ FINITE A /\ is_perm apm``
-val ctxt_s_supp =
-    ``support (fnpm (cpmpm) apm) s sS /\ FINITE sS``
-val ctxt_s12_supp =
-    ``support (fnpm (cpmpm) apm) s1 sS1 /\
-      FINITE sS1 /\
-      support (fnpm (cpmpm) apm) s2 sS2 /\
-      FINITE sS2``
+val tpm_is_perm = Store_thm(
+  tpm_name ^ "_is_perm",
+  ``is_perm ^tpm_t``,
+  srw_tac [][is_perm_def, FUN_EQ_THM, tpm_def, gtpm_NIL,
+             GSYM gtpm_compose, repabs_pseudo_id, absrep_id]
+  >- srw_tac [][GSYM term_REP_tpm, absrep_id] >>
+  AP_TERM_TAC >>
+  (is_perm_def |> ISPEC ``generic_terms$gtpm`` |> C EQ_MP gtpm_is_perm
+               |> CONJUNCTS |> last |> REWRITE_RULE [FUN_EQ_THM]
+               |> MATCH_MP_TAC) >>
+  POP_ASSUM ACCEPT_TAC)
 
-val ssupport_fresh = UNDISCH (UNDISCH (prove(
-  ``support (fnpm (cpmpm) apm) s sS ==>
-    is_perm apm ==>
-    !x y p.
-      ~(x IN sS) /\ ~(y IN sS) ==>
-      (apm [(x,y)] (s p) = s (cpmpm [(x,y)] p))``,
-  REPEAT STRIP_TAC THEN
-  MATCH_MP_TAC (Q.GEN `A` support_freshf) THEN Q.EXISTS_TAC `sS` THEN
-  SRW_TAC [][])));
+fun tpm_clause contermP con_def =
+  con_def |> SPEC_ALL
+          |> Q.AP_TERM `^tpm_t pi`
+          |> CONV_RULE (RAND_CONV (SIMP_CONV bool_ss [tpm_def]))
+          |> SIMP_RULE std_ss [repabs_pseudo_id, contermP, gtpm_thm, listTheory.MAP,
+                               listpm_def]
+          |> SIMP_RULE bool_ss [GSYM con_def, GSYM term_REP_tpm]
+          |> GEN_ALL
 
-val s1support_fresh = Q.INST [`s` |-> `s1`, `sS` |-> `sS1`] ssupport_fresh
-val s2support_fresh = Q.INST [`s` |-> `s2`, `sS` |-> `sS2`] ssupport_fresh
+val tpm_thm = Save_thm(
+  tpm_name ^ "_thm",
+  LIST_CONJ [tpm_clause VAR_termP VAR_def,
+             tpm_clause APP_termP (GSYM APP_def'),
+             tpm_clause LAM_termP LAM_def,
+             tpm_clause LAMi_termP LAMi_def]);
 
-val h_supported_by = prove(
-  ``!a s sS pi.
-       ^ctxt00 /\ ^ctxt_s_supp ==>
-       support (fnpm perm_of apm) ^h (a INSERT (A UNION patoms pi UNION sS))``,
-  REPEAT STRIP_TAC THEN
-  MAP_EVERY ASSUME_TAC [lamf_support_fresh, ssupport_fresh] THEN
-  SRW_TAC [][support_def, FUN_EQ_THM, fnpm_def, listpm_APPENDlist]);
-val i_supported_by = prove(
-  ``!a s1 s2 sS1 sS2 pi.
-       ^ctxt00 /\ ^ctxt_s_supp ==>
-       support (fnpm perm_of (fnpm apm apm)) ^i
-               (a INSERT A UNION patoms pi UNION sS)``,
-  REPEAT STRIP_TAC THEN
-  MAP_EVERY ASSUME_TAC [limf_support_fresh, ssupport_fresh] THEN
-  SRW_TAC [][support_def, FUN_EQ_THM, fnpm_def, listpm_APPENDlist,
-             is_perm_sing_inv]);
 
-val _ = print "Proving cond16 implies freshness ok... "
-val cond16 = ``?a'. ~(a' IN A) /\ !x. ~(a' IN supp apm (^lamf a' x))``
-val cond16i = ``?a'. ~(a' IN A) /\
-                      !n x. ~(a' IN supp (fnpm apm apm) (^limf n a' x))``
+(* support *)
+val term_REP_eqv = prove(
+   ``support (fnpm ^tpm_t gtpm) ^term_REP_t {}`` ,
+   srw_tac [][support_def, fnpm_def, FUN_EQ_THM, term_REP_tpm, gtpm_sing_inv]);
 
-val cond16_implies_freshness_ok = prove(
-  ``!a s A sS.
-       ^ctxt00 /\ ^ctxt_s_supp /\ ^cond16 ==>
-       ?a'. ~(a' IN ^h_supp_t) /\ ~(a' IN supp apm (^h a'))``,
-  REPEAT STRIP_TAC THEN
-  Q.ABBREV_TAC `h = ^h` THEN
-  `!a'' x. ~(a'' IN A) /\ ~(a' = a'') ==>
-           ~(a'' IN supp apm (lamf a'' (apm [(a',a'')] x)))`
-      by (REPEAT GEN_TAC THEN STRIP_TAC THEN
-          `lamf a'' = fnpm apm apm [(a',a'')] (lamf a')`
-              by SRW_TAC [][fnpm_def, FUN_EQ_THM, is_perm_sing_inv,
-                            lamf_support_fresh] THEN
-          SRW_TAC [][fnpm_def, is_perm_sing_inv, perm_supp]) THEN
-  Q_TAC (NEW_TAC "a''") `{a;a'} UNION A UNION sS UNION patoms pi` THEN
-  `support (fnpm perm_of apm) h (a INSERT A UNION patoms pi UNION sS)`
-     by (UNABBREV_ALL_TAC THEN MATCH_MP_TAC h_supported_by THEN
-         SRW_TAC [][]) THEN
-  Q.EXISTS_TAC `a''` THEN SRW_TAC [][] THENL [
-    `~(a'' IN a INSERT A UNION patoms pi UNION sS)` by SRW_TAC [][] THEN
-    `FINITE (a INSERT A UNION patoms pi UNION sS)` by SRW_TAC [][] THEN
-    METIS_TAC [supp_smallest, SUBSET_DEF, fnpm_is_perm, perm_of_is_perm],
-    Q.UNABBREV_TAC `h` THEN
-    FIRST_X_ASSUM
-      (Q.SPECL_THEN [`a''`, `apm [(a',a'')] (s (pi ++ [(a'',a)]))`]
-         MP_TAC) THEN
-    SRW_TAC [][is_perm_sing_inv]
-  ]);
+val supp_term_REP = prove(
+  ``supp (fnpm ^tpm_t gtpm) ^term_REP_t = {}``,
+  REWRITE_TAC [GSYM SUBSET_EMPTY] >> MATCH_MP_TAC (GEN_ALL supp_smallest) >>
+  srw_tac [][gtpm_is_perm, tpm_is_perm, term_REP_eqv])
 
-val cond16i_implies_freshness_ok = prove(
-  ``!a s sS A.
-       ^ctxt00 /\ ^ctxt_s_supp /\ ^cond16i ==>
-       ?a'. ~(a' IN ^i_supp_t) /\ ~(a' IN supp (fnpm apm apm) (^i a'))``,
-  REPEAT STRIP_TAC THEN
-  Q.ABBREV_TAC `i = ^i` THEN
-  `!a'' n x. ~(a'' IN A) /\ ~(a' = a'') ==>
-             ~(a'' IN supp (fnpm apm apm) (limf n a'' (apm [(a',a'')] x)))`
-      by (REPEAT GEN_TAC THEN STRIP_TAC THEN
-          `limf n' a'' = fnpm apm (fnpm apm apm) [(a',a'')] (limf n' a')`
-              by SRW_TAC [][fnpm_def, FUN_EQ_THM, is_perm_sing_inv,
-                            limf_support_fresh] THEN
-          SRW_TAC [][fnpm_def, is_perm_sing_inv, perm_supp]) THEN
-  Q_TAC (NEW_TAC "a''") `{a;a'} UNION A UNION sS UNION patoms pi` THEN
-  `support (fnpm perm_of (fnpm apm apm)) i
-           (a INSERT A UNION patoms pi UNION sS)`
-     by (UNABBREV_ALL_TAC THEN MATCH_MP_TAC i_supported_by THEN
-         SRW_TAC [][]) THEN
-  Q.EXISTS_TAC `a''` THEN SRW_TAC [][] THENL [
-    `~(a'' IN a INSERT A UNION patoms pi UNION sS)`
-       by SRW_TAC [][] THEN
-    `FINITE (a INSERT A UNION patoms pi UNION sS)`
-       by SRW_TAC [][] THEN
-    METIS_TAC [supp_smallest, SUBSET_DEF, fnpm_is_perm, perm_of_is_perm],
-    Q.UNABBREV_TAC `i` THEN
-    FIRST_X_ASSUM
-      (Q.SPECL_THEN [`a''`, `n`, `apm [(a',a'')] (s (pi ++ [(a'',a)]))`]
-         MP_TAC) THEN
-    SRW_TAC [][is_perm_sing_inv]
-  ]);
-val _ = print "done\n"
+val supptpm_support = prove(
+  ``support ^tpm_t ^t (supp gtpm (^term_REP_t ^t))``,
+  srw_tac [][support_def, tpm_def, gtpm_fresh, absrep_id]);
 
-val base =
-    SPECL [``\(s:string) p. vr (perm_of p s) : 'a``]
-          (INST_TYPE [alpha |-> ``:(string # string) list -> 'a``]
-                     (TypeBase.axiom_of ``:prelterm$l0term``))
-val full0 = Q.SPECL [`\t u r1 r2 p. ap (r1 p) (r2 p)`,
-                    `\a t s pi. fresh apm ^h`,
-                    `\n a t1 t2 s s2 pi. fresh (fnpm apm apm) ^i (s2 pi)`] base
+val supptpm_apart = prove(
+  ``x ∈ supp gtpm (^term_REP_t ^t) ∧ y ∉ supp gtpm (^term_REP_t ^t) ⇒
+    ^tpm_t [(x,y)] ^t ≠ ^t``,
+  srw_tac [][tpm_def]>>
+  DISCH_THEN (MP_TAC o AP_TERM term_REP_t) >>
+  srw_tac [][repabs_pseudo_id, genind_gtpm_eqn, genind_term_REP, supp_apart,
+             gtpm_is_perm]);
 
-val full = SIMP_RULE (srw_ss()) [FUN_EQ_THM] full0
+val supp_tpm = prove(
+  ``supp ^tpm_t ^t = supp gtpm (^term_REP_t ^t)``,
+  match_mp_tac (GEN_ALL supp_unique_apart) >>
+  srw_tac [][supptpm_support, supptpm_apart, FINITE_GFV, tpm_is_perm])
 
-val fndefn = #2 (dest_exists (concl full))
+val _ = overload_on ("FV", ``supp ^tpm_t``)
 
-val swapstr_perm_of = store_thm(
-  "swapstr_perm_of",
-  ``swapstr x y (perm_of pi s) =
-    perm_of (cpmpm [(x,y)] pi) (swapstr x y s)``,
-  Induct_on `pi` THEN
-  SIMP_TAC (srw_ss()) [pairTheory.FORALL_PROD, listpm_def, pairpm_def] THEN
-  POP_ASSUM (SUBST1_TAC o SYM) THEN SRW_TAC [][]);
+val FINITE_FV = Store_thm(
+  "FINITE_FV",
+  ``FINITE (FV ^t)``,
+  srw_tac [][supp_tpm, FINITE_GFV]);
 
-val _ = print "Proving function is supported by set A... "
-val rawfinite_support = prove(
-  ``^fndefn /\ ^ctxt00 /\ ^cond16 /\ ^cond16i /\ ^var_support_t /\
-    ^app_support_t ==>
-    support (fnpm ptpm (fnpm (cpmpm) apm)) fn A``,
-  STRIP_TAC THEN SIMP_TAC (srw_ss()) [support_def, FUN_EQ_THM, fnpm_def] THEN
-  Q_TAC SUFF_TAC
-        `!t pi x y.  ~(x IN A) /\ ~(y IN A) ==>
-                     (apm [(x,y)] (fn (ptpm [(x,y)] t) (cpmpm [(x,y)] pi)) =
-                      fn t pi)`
-        THEN1 PROVE_TAC [] THEN
-  Induct THENL [
-    SRW_TAC [][fnpm_def] THEN
-    `(!s. apm [(x,y)] (vr s) = vr (perm_of [(x,y)] s))`
-        by (MATCH_MP_TAC support_freshf THEN SRW_TAC [][]) THEN
-    SRW_TAC [][swapstr_perm_of, is_perm_sing_inv],
+fun supp_clause contermP con_def = let
+  val t = mk_comb(``supp ^tpm_t``, lhand (concl (SPEC_ALL con_def)))
+in
+  t |> SIMP_CONV (srw_ss()) [supp_tpm, con_def, repabs_pseudo_id, contermP,
+                             GFV_thm]
+    |> SIMP_RULE (srw_ss()) [GSYM supp_tpm]
+    |> GEN_ALL
+end
 
-    SRW_TAC [][fnpm_def] THEN
-    `!a b pi. apm pi (ap a b) =
-              fnpm apm apm pi (ap a) (apm pi b)`
-        by SRW_TAC [][fnpm_def, is_perm_inverse] THEN
-    SRW_TAC [][] THEN
-    `!t. fnpm apm apm [(x,y)] (ap t) = ap (apm [(x,y)] t)`
-        by (MATCH_MP_TAC support_freshf THEN SRW_TAC [][]) THEN
-    SRW_TAC [][],
+val FV_thm = Save_thm(
+  "FV_thm",
+  LIST_CONJ
+    [supp_clause VAR_termP VAR_def,
+     supp_clause APP_termP APP_def,
+     supp_clause LAM_termP LAM_def,
+     supp_clause LAMi_termP LAMi_def]);
 
-    ASM_SIMP_TAC (srw_ss()) [fnpm_def] THEN
-    Q.X_GEN_TAC `s` THEN SRW_TAC [][] THEN
-    Q.MATCH_ABBREV_TAC `apm [(x,y)] (fresh apm g) = fresh apm h` THEN
-    `h = fnpm perm_of apm [(x,y)] g`
-       by (MAP_EVERY Q.UNABBREV_TAC [`g`, `h`] THEN
-           SIMP_TAC (srw_ss()) [FUN_EQ_THM] THEN Q.X_GEN_TAC `a` THEN
-           SRW_TAC [][fnpm_def, lamf_support_fresh] THEN
-           `cpmpm [(x,y)] pi ++ [(swapstr x y a, swapstr x y s)] =
-                cpmpm [(x,y)] (pi ++ [(a,s)])`
-              by SRW_TAC [][listpm_APPENDlist] THEN
-           SRW_TAC [][]) THEN
-    POP_ASSUM (fn th =>
-                  Q_TAC SUFF_TAC `fcond apm h` THEN1
-                        SRW_TAC [][fresh_equivariant, is_perm_eql,
-                                   is_perm_sing_inv, th]) THEN
-    UNABBREV_ALL_TAC THEN
-    `support (fnpm (cpmpm) apm) (fn t) (A UNION allatoms t)`
-       by (SIMP_TAC (srw_ss()) [support_def, FUN_EQ_THM, fnpm_def] THEN
-           MAP_EVERY Q.X_GEN_TAC [`c`, `d`] THEN REPEAT STRIP_TAC THEN
-           `!x. apm [(c,d)] (fn t x) =
-                fnpm (cpmpm) apm [(c,d)] (fn t) (cpmpm [(c,d)] x)`
-             by SRW_TAC [][fnpm_def, is_perm_sing_inv] THEN
-           SRW_TAC [][is_perm_sing_inv] THEN
-           `fnpm (cpmpm) apm [(c,d)] (fn t) =
-            fnpm ptpm (fnpm (cpmpm) apm) [(c,d)] fn
-                 (ptpm [(c,d)] t)`
-             by SRW_TAC [][fnpm_def] THEN
-           `ptpm [(c,d)] t = t`
-             by PROVE_TAC [allatoms_supports, support_def] THEN
-           SRW_TAC [][] THEN
-           NTAC 3 (POP_ASSUM (K ALL_TAC)) THEN SRW_TAC [][fnpm_def]) THEN
-    Q.ABBREV_TAC `bigA = A UNION allatoms t UNION patoms pi` THEN
-    `support (fnpm perm_of (fnpm apm apm)) lamf bigA /\
-     support (fnpm (cpmpm) apm) (fn t) bigA /\
-     support (cpmpm) pi bigA`
-       by FULL_SIMP_TAC (srw_ss()) [support_def, Abbr`bigA`] THEN
-    SRW_TAC [][fcond_def] THENL [
-      Q.MATCH_ABBREV_TAC `FINITE (supp pm h)` THEN
-      Q_TAC SUFF_TAC `?X. FINITE X /\ support pm h X`
-            THEN1 METIS_TAC [SUBSET_FINITE, supp_smallest, fnpm_is_perm,
-                             perm_of_is_perm] THEN
-      Q.EXISTS_TAC `s INSERT A UNION patoms pi UNION (A UNION allatoms t)` THEN
-      SRW_TAC [][Abbr`bigA`, Abbr`h`, Abbr`pm`] THEN
-      MATCH_MP_TAC h_supported_by THEN
-      SRW_TAC [][],
 
-      MATCH_MP_TAC (BETA_RULE cond16_implies_freshness_ok) THEN
-      MAP_EVERY Q.EXISTS_TAC [`A`, `A UNION allatoms t`] THEN
-      SRW_TAC [][] THEN METIS_TAC []
-    ],
+fun genit th = let
+  val (_, args) = strip_comb (concl th)
+  val (tm, x) = case args of [x,y] => (x,y) | _ => raise Fail "Bind"
+  val ty = type_of tm
+  val t = mk_var("t", ty)
+in
+  th |> INST [tm |-> t] |> GEN x |> GEN t
+end
 
-    Q.X_GEN_TAC `s` THEN SRW_TAC [][fnpm_def] THEN
-    Q.MATCH_ABBREV_TAC
-      `apm [(x,y)] (fresh (fnpm apm apm) g arg1) =
-       fresh (fnpm apm apm) h arg2` THEN
-    `h = fnpm perm_of (fnpm apm apm) [(x,y)] g`
-       by (MAP_EVERY Q.UNABBREV_TAC [`g`, `h`] THEN
-           SIMP_TAC (srw_ss()) [FUN_EQ_THM] THEN Q.X_GEN_TAC `a` THEN
-           SRW_TAC [][fnpm_def, limf_support_fresh, is_perm_sing_inv] THEN
-           `cpmpm [(x,y)] pi ++ [(swapstr x y a, swapstr x y s)] =
-                cpmpm [(x,y)] (pi ++ [(a,s)])`
-              by SRW_TAC [][listpm_APPENDlist, listpm_def, pairpm_def] THEN
-           SRW_TAC [][]) THEN
-    `arg2 = apm [(x,y)] arg1` by SRW_TAC [][Abbr`arg1`, Abbr`arg2`,
-                                            is_perm_sing_inv] THEN
-    Q.PAT_ASSUM `h = foo` (fn th =>
-                  Q_TAC SUFF_TAC `fcond (fnpm apm apm) h` THEN1
-                        (`apm [(x,y)] (fresh (fnpm apm apm) g arg1) =
-                          fnpm apm apm [(x,y)] (fresh (fnpm apm apm) g)
-                                               (apm [(x,y)] arg1)`
-                             by SRW_TAC [][fnpm_def, is_perm_sing_inv] THEN
+val LIST_REL_CONS1 = listTheory.LIST_REL_CONS1
+val LIST_REL_NIL = listTheory.LIST_REL_NIL
 
-                         SRW_TAC [][fresh_equivariant, th])) THEN
-    UNABBREV_ALL_TAC THEN
-    `support (fnpm (cpmpm) apm) (fn t)
-             (A UNION allatoms t)`
-       by (SIMP_TAC (srw_ss()) [support_def, FUN_EQ_THM, fnpm_def] THEN
-           MAP_EVERY Q.X_GEN_TAC [`c`, `d`] THEN REPEAT STRIP_TAC THEN
-           `!x. apm [(c,d)] (fn t x) =
-                fnpm (cpmpm) apm [(c,d)] (fn t)
-                     (cpmpm [(c,d)] x)`
-             by SRW_TAC [][fnpm_def, is_perm_sing_inv] THEN
-           SRW_TAC [][is_perm_sing_inv] THEN
-           `fnpm (cpmpm) apm [(c,d)] (fn t) =
-            fnpm ptpm (fnpm (cpmpm) apm) [(c,d)] fn
-                 (ptpm [(c,d)] t)`
-             by SRW_TAC [][fnpm_def] THEN
-           `ptpm [(c,d)] t = t`
-             by PROVE_TAC [allatoms_supports, support_def] THEN
-           SRW_TAC [][] THEN
-           NTAC 3 (POP_ASSUM (K ALL_TAC)) THEN SRW_TAC [][fnpm_def]) THEN
-    Q.ABBREV_TAC `bigA = A UNION allatoms t UNION patoms pi` THEN
-    `support (fnpm perm_of (fnpm apm apm)) lamf bigA /\
-     support (fnpm (cpmpm) apm) (fn t) bigA /\
-     support (cpmpm) pi bigA`
-       by FULL_SIMP_TAC (srw_ss()) [support_def, Abbr`bigA`] THEN
-    SRW_TAC [][fcond_def] THENL [
-      Q.MATCH_ABBREV_TAC `FINITE (supp pm h)` THEN
-      Q_TAC SUFF_TAC `?X. FINITE X /\ support pm h X`
-            THEN1 METIS_TAC [SUBSET_FINITE, supp_smallest, fnpm_is_perm,
-                             perm_of_is_perm] THEN
-      Q.EXISTS_TAC
-        `s INSERT A UNION patoms pi UNION (A UNION allatoms t)` THEN
-      SRW_TAC [][Abbr`bigA`, Abbr`h`, Abbr`pm`] THEN
-      MATCH_MP_TAC i_supported_by THEN
-      SRW_TAC [][],
+val term_ind =
+    bvc_genind |> INST_TYPE [alpha |-> ``:unit+unit+num``, beta |-> ``:unit``]
+               |> Q.INST [`vp` |-> `^vp`, `lp` |-> `^lp`]
+               |> SIMP_RULE std_ss [LIST_REL_CONS1, RIGHT_AND_OVER_OR,
+                                    LEFT_AND_OVER_OR, DISJ_IMP_THM, LIST_REL_NIL]
+               |> Q.SPEC `λn t0 x. Q t0 x`
+               |> Q.SPEC `fv`
+               |> UNDISCH |> Q.SPEC `0` |> DISCH_ALL
+               |> SIMP_RULE (std_ss ++ DNF_ss)
+                            [sumTheory.FORALL_SUM, supp_listpm,
+                             IN_UNION, NOT_IN_EMPTY, oneTheory.FORALL_ONE,
+                             genind_exists, LIST_REL_CONS1, LIST_REL_NIL]
+               |> Q.INST [`Q` |-> `λt. P (^term_ABS_t t)`]
+               |> SIMP_RULE std_ss [GSYM LAM_def, APP_def', GSYM VAR_def, absrep_id,
+                                    GSYM LAMi_def, GSYM supp_tpm]
+               |> elim_unnecessary_atoms {finite_fv = FINITE_FV}
+                                         [ASSUME ``!x:'c. FINITE (fv x:string set)``]
+               |> SPEC_ALL |> UNDISCH
+               |> genit |> DISCH_ALL |> Q.GEN `fv` |> Q.GEN `P`
 
-      MATCH_MP_TAC (BETA_RULE cond16i_implies_freshness_ok) THEN
-      MAP_EVERY Q.EXISTS_TAC [`A UNION allatoms t`, `A`] THEN
-      SRW_TAC [][] THEN METIS_TAC []
-    ]
-  ]);
-val _ = print "done\n"
+fun mkX_ind th = th |> Q.SPEC `λt x. Q t` |> Q.SPEC `λx. X`
+                    |> SIMP_RULE std_ss [] |> Q.GEN `X`
+                    |> Q.INST [`Q` |-> `P`] |> Q.GEN `P`
 
-val eqperms_ok = prove(
-  ``^fndefn ==>
-    !t p1 p2. (p1 == p2) ==> (fn t p1 = fn t p2)``,
-  STRIP_TAC THEN Induct THENL [
-    FULL_SIMP_TAC (srw_ss()) [permeq_def],
-    METIS_TAC [],
-    MAP_EVERY Q.X_GEN_TAC [`s`, `p1`, `p2`] THEN SRW_TAC [][] THEN
-    Q_TAC SUFF_TAC `!a. fn t (p1 ++ [(a,s)]) = fn t (p2 ++ [(a,s)])` THEN1
-          SRW_TAC [][] THEN
-    GEN_TAC THEN FIRST_X_ASSUM MATCH_MP_TAC THEN
-    MATCH_MP_TAC app_permeq_monotone THEN
-    SRW_TAC [][permeq_refl],
-    MAP_EVERY Q.X_GEN_TAC [`s`, `n`, `p1`, `p2`] THEN SRW_TAC [][] THEN
-    Q_TAC SUFF_TAC `(!a. fn t (p1 ++ [(a,s)]) = fn t (p2 ++ [(a,s)])) /\
-                    (fn t' p1 = fn t' p2)` THEN1 SIMP_TAC (srw_ss()) [] THEN
-    SRW_TAC [][] THEN FIRST_X_ASSUM MATCH_MP_TAC THEN
-    MATCH_MP_TAC app_permeq_monotone THEN SRW_TAC [][permeq_refl]
-  ]);
+val LAMi_eq_thm = save_thm(
+  "lLAMi_eq_thm",
+  ``^LAMi_t n1 v1 t1 u1 = ^LAMi_t n2 v2 t2 u2``
+   |> SIMP_CONV (srw_ss()) [LAMi_def, LAMi_termP, term_ABS_pseudo11,
+                            GLAM_eq_thm, term_REP_11, GSYM term_REP_tpm,
+                            GSYM supp_tpm])
 
-val fn_support_fresh = UNDISCH (UNDISCH (prove(
-  ``support (fnpm ptpm (fnpm (cpmpm) apm)) fn A ==>
-    is_perm apm ==>
-    !x y M p.
-       ~(x IN A) /\ ~(y IN A) ==>
-       (apm [(x,y)] (fn M p) =
-          fn (ptpm [(x,y)] M) (cpmpm [(x,y)] p))``,
-  REPEAT STRIP_TAC THEN
-  `apm [(x,y)] (fn M p) =
-       fnpm (cpmpm) apm [(x,y)] (fn M)
-            (cpmpm [(x,y)] p)`
-     by SRW_TAC [][fnpm_def, is_perm_sing_inv] THEN
-  SRW_TAC [][] THEN AP_THM_TAC THEN
-  MATCH_MP_TAC support_freshf THEN SRW_TAC [][])))
+val LAM_eq_thm = save_thm(
+  "lLAM_eq_thm",
+  ``^LAM_t v1 t1 = ^LAM_t v2 t2``
+   |> SIMP_CONV (srw_ss()) [LAM_def, LAM_termP, term_ABS_pseudo11,
+                            GLAM_eq_thm, term_REP_11, GSYM term_REP_tpm,
+                            GSYM supp_tpm])
 
-val _ = print "Proving that permutations can be re-arranged... "
-val perms_move = prove(
-  ``^fndefn /\ ^var_support_t /\ ^app_support_t /\ ^cond16 /\ ^cond16i /\
-    ^ctxt00 ==>
-    !t p1 p2. fn (ptpm p2 t) p1 = fn t (p1 ++ p2)``,
-  STRIP_TAC THEN Induct THEN
-  TRY (SRW_TAC [][lswapstr_APPEND] THEN
-       SRW_TAC [][GSYM lswapstr_APPEND] THEN NO_TAC)
-  THENL [
-    MAP_EVERY Q.X_GEN_TAC [`s`, `p1`, `p2`] THEN SRW_TAC [][] THEN
-    Q.MATCH_ABBREV_TAC `fresh apm f = fresh apm g` THEN
-    `support (fnpm ptpm (fnpm (cpmpm) apm)) fn A`
-       by (MATCH_MP_TAC rawfinite_support THEN SRW_TAC [][] THEN
-           METIS_TAC []) THEN
-    ASSUME_TAC fn_support_fresh THEN
-    Q.ABBREV_TAC
-      `bigS = s INSERT A UNION allatoms t UNION patoms p1 UNION patoms p2` THEN
-    ASSUME_TAC allatoms_fresh THEN
-    ASSUME_TAC lamf_support_fresh THEN
-    Q.PAT_ASSUM `!p1 p2. fn (ptpm p2 t) p1 = fn t (p1 ++ p2)` (K ALL_TAC) THEN
-    `support (fnpm perm_of apm) f bigS /\ support (fnpm perm_of apm) g bigS`
-       by (SRW_TAC [][support_def, FUN_EQ_THM, fnpm_def, Abbr`f`, Abbr`g`,
-                      Abbr`bigS`, listpm_APPENDlist, listpm_def, pairpm_def] THEN
-           SRW_TAC [][swapstr_perm_of, swapstr_def]) THEN
-    `FINITE bigS` by SRW_TAC [][Abbr`bigS`] THEN
-    `?b. ~(b IN bigS)` by METIS_TAC [NEW_def] THEN
-    `~(b IN supp (fnpm perm_of apm) f) /\ ~(b IN supp (fnpm perm_of apm) g)`
-        by METIS_TAC [supp_smallest, SUBSET_DEF, fnpm_is_perm,
-                      perm_of_is_perm] THEN
-    `FINITE (supp (fnpm perm_of apm) f) /\ FINITE (supp (fnpm perm_of apm) g)`
-        by METIS_TAC [supp_smallest, SUBSET_FINITE, fnpm_is_perm,
-                      perm_of_is_perm] THEN
-    `fcond apm f /\ fcond apm g`
-        by (SRW_TAC [][fcond_def] THENL [
-              `f = \c. lamf c ((\p. fn t (p ++ p2)) (p1 ++ [(c, perm_of p2 s)]))`
-                 by SRW_TAC [][Abbr`f`] THEN
-              POP_ASSUM SUBST1_TAC THEN
-              MATCH_MP_TAC cond16_implies_freshness_ok THEN
-              MAP_EVERY Q.EXISTS_TAC
-                        [`A`, `A UNION allatoms t UNION patoms p2`] THEN
-              SRW_TAC [][] THENL [
-                SRW_TAC [][support_def, fnpm_def, FUN_EQ_THM, listpm_APPENDlist,
-                           is_perm_sing_inv],
-                METIS_TAC []
-              ],
-              Q.UNABBREV_TAC `g` THEN
-              MATCH_MP_TAC cond16_implies_freshness_ok THEN
-              MAP_EVERY Q.EXISTS_TAC [`A`, `A UNION allatoms t`] THEN
-              SRW_TAC [][] THENL [
-                SRW_TAC [][support_def, FUN_EQ_THM, fnpm_def,
-                           is_perm_sing_inv],
-                METIS_TAC []
-              ]
-            ]) THEN
-    `(fresh apm f = f b) /\ (fresh apm g = g b)` by METIS_TAC [fresh_thm] THEN
-    SRW_TAC [][Abbr`f`, Abbr`g`] THEN
-    Q_TAC SUFF_TAC `p1 ++ [(b,perm_of p2 s)] ++ p2 == p1 ++ p2 ++ [(b,s)]`
-          THEN1 (STRIP_TAC THEN
-                 Q_TAC SUFF_TAC
-                       `fn t (p1 ++ [(b,perm_of p2 s)] ++ p2) =
-                        fn t (p1 ++ p2 ++ [(b,s)])` THEN1 SRW_TAC [][] THEN
-                 MP_TAC eqperms_ok THEN SRW_TAC [][]) THEN
-    REWRITE_TAC [GSYM listTheory.APPEND_ASSOC] THEN
-    MATCH_MP_TAC app_permeq_monotone THEN
-    SRW_TAC [][permeq_refl] THEN
-    `(perm_of p2 b, perm_of p2 s) :: p2 == p2 ++ [(b,s)]`
-        by METIS_TAC [permeq_swap_ends, permeq_sym] THEN
-    Q_TAC SUFF_TAC `perm_of p2 b = b` THEN1 METIS_TAC [] THEN
-    `~(b IN patoms p2)` by FULL_SIMP_TAC (srw_ss()) [Abbr`bigS`] THEN
-    SRW_TAC [][perm_of_unchanged],
+val (_, repty) = dom_rng (type_of term_REP_t)
+val repty' = ty_antiq repty
 
-    MAP_EVERY Q.X_GEN_TAC [`s`, `n`, `p1`, `p2`] THEN SRW_TAC [][] THEN
-    AP_THM_TAC THEN
-    Q.MATCH_ABBREV_TAC `fresh (fnpm apm apm) f = fresh (fnpm apm apm) g` THEN
-    `support (fnpm ptpm (fnpm (cpmpm) apm)) fn A`
-       by (MATCH_MP_TAC rawfinite_support THEN SRW_TAC [][] THEN
-           METIS_TAC []) THEN
-    ASSUME_TAC fn_support_fresh THEN
-    Q.ABBREV_TAC
-      `bigS = s INSERT A UNION allatoms t UNION patoms p1 UNION patoms p2` THEN
-    ASSUME_TAC limf_support_fresh THEN
-    Q.PAT_ASSUM `!p1 p2. fn (ptpm p2 t) p1 = fn t (p1 ++ p2)` (K ALL_TAC) THEN
-    Q.PAT_ASSUM `!p1 p2. fn (ptpm p2 t') p1 = fn t' (p1 ++ p2)`
-                (K ALL_TAC) THEN
-    `support (fnpm perm_of (fnpm apm apm)) f bigS /\
-     support (fnpm perm_of (fnpm apm apm)) g bigS`
-       by (SRW_TAC [][support_def, FUN_EQ_THM, fnpm_def, Abbr`f`, Abbr`g`,
-                      Abbr`bigS`, listpm_APPENDlist, listpm_def, pairpm_def,
-                      allatoms_fresh] THEN
-           SRW_TAC [][swapstr_perm_of, swapstr_def, is_perm_sing_inv]) THEN
-    `FINITE bigS` by SRW_TAC [][Abbr`bigS`] THEN
-    `?b. ~(b IN bigS)` by METIS_TAC [NEW_def] THEN
-    `~(b IN supp (fnpm perm_of (fnpm apm apm)) f) /\
-     ~(b IN supp (fnpm perm_of (fnpm apm apm)) g)`
-        by METIS_TAC [supp_smallest, SUBSET_DEF, fnpm_is_perm,
-                      perm_of_is_perm] THEN
-    `FINITE (supp (fnpm perm_of (fnpm apm apm)) f) /\
-     FINITE (supp (fnpm perm_of (fnpm apm apm)) g)`
-        by METIS_TAC [supp_smallest, SUBSET_FINITE, fnpm_is_perm,
-                      perm_of_is_perm] THEN
-    `fcond (fnpm apm apm) f /\ fcond (fnpm apm apm) g`
-        by (SRW_TAC [][fcond_def] THENL [
-              `f = \c. limf n c
-                          ((\p. fn t (p ++ p2)) (p1 ++ [(c, perm_of p2 s)]))`
-                 by SRW_TAC [][Abbr`f`] THEN
-              POP_ASSUM SUBST1_TAC THEN
-              MATCH_MP_TAC cond16i_implies_freshness_ok THEN
-              MAP_EVERY Q.EXISTS_TAC
-                        [`A UNION allatoms t UNION patoms p2`, `A`] THEN
-              SRW_TAC [][] THENL [
-                SRW_TAC [][support_def, fnpm_def, FUN_EQ_THM, listpm_APPENDlist,
-                           is_perm_sing_inv, allatoms_fresh],
-                METIS_TAC []
-              ],
-              Q.UNABBREV_TAC `g` THEN
-              MATCH_MP_TAC cond16i_implies_freshness_ok THEN
-              MAP_EVERY Q.EXISTS_TAC [`A UNION allatoms t`, `A`] THEN
-              SRW_TAC [][] THENL [
-                SRW_TAC [][support_def, FUN_EQ_THM, fnpm_def,
-                           is_perm_sing_inv, allatoms_fresh],
-                METIS_TAC []
-              ]
-            ]) THEN
-    `(fresh (fnpm apm apm) f = f b) /\ (fresh (fnpm apm apm) g = g b)`
-       by METIS_TAC [fresh_thm] THEN
-    SRW_TAC [][Abbr`f`, Abbr`g`] THEN
-    Q_TAC SUFF_TAC `p1 ++ [(b,perm_of p2 s)] ++ p2 == p1 ++ p2 ++ [(b,s)]`
-          THEN1 (STRIP_TAC THEN
-                 Q_TAC SUFF_TAC
-                       `fn t (p1 ++ [(b,perm_of p2 s)] ++ p2) =
-                        fn t (p1 ++ p2 ++ [(b,s)])` THEN1 SRW_TAC [][] THEN
-                 MP_TAC eqperms_ok THEN SRW_TAC [][]) THEN
-    REWRITE_TAC [GSYM listTheory.APPEND_ASSOC] THEN
-    MATCH_MP_TAC app_permeq_monotone THEN
-    SRW_TAC [][permeq_refl] THEN
-    `(perm_of p2 b, perm_of p2 s) :: p2 == p2 ++ [(b,s)]`
-        by METIS_TAC [permeq_swap_ends, permeq_sym] THEN
-    Q_TAC SUFF_TAC `perm_of p2 b = b` THEN1 METIS_TAC [] THEN
-    `~(b IN patoms p2)` by FULL_SIMP_TAC (srw_ss()) [Abbr`bigS`] THEN
-    SRW_TAC [][perm_of_unchanged]
-  ]);
-val _ = print "done\n"
+val tlf =
+  ``λ(v:string) (u:unit + unit + num)
+                (ds1:(ρ -> α) list) (ds2:(ρ -> α) list)
+                (ts1:^repty' list) (ts2:^repty' list) (p:ρ).
+       if ISL u then ap (HD ds2) (HD (TL ds2)) (^term_ABS_t (HD ts2))
+                        (^term_ABS_t (HD (TL ts2))) p: α
+       else if ISL (OUTR u) then
+         lm (HD ds1) v (^term_ABS_t (HD ts1)) p: α
+       else
+         li (HD ds1) (HD ds2) (OUTR (OUTR u)) v
+            (^term_ABS_t (HD ts1)) (^term_ABS_t (HD ts2)) p``
+val tvf = ``λ(s:string) (u:unit) (p:ρ). vr' s p: α``
 
-val _ = print "Proving that the function respects alpha-equivalence... "
-val fn_respectful = prove(
-  ``^fndefn /\ ^var_support_t /\ ^app_support_t /\ ^cond16 /\ ^cond16i /\
-    ^ctxt00 /\
-    aeq t1 t2 ==> !p. fn t1 p = fn t2 p``,
-  STRIP_TAC THEN
-  Q.UNDISCH_THEN `aeq t1 t2` MP_TAC THEN
-  MAP_EVERY Q.ID_SPEC_TAC [`t2`, `t1`] THEN
-  HO_MATCH_MP_TAC alt_aeq_ind THEN SRW_TAC [][] THEN
-  `!t p1 p2. fn (ptpm p1 t) p2 = fn t (p2 ++ p1)`
-      by (MATCH_MP_TAC perms_move THEN SRW_TAC [][] THEN METIS_TAC []) THEN
-  POP_ASSUM (ASSUME_TAC o GSYM) THEN SRW_TAC [][] THENL [
-    ALL_TAC,
-    AP_THM_TAC
-  ] THEN
-  Q.MATCH_ABBREV_TAC `fresh somepm f = fresh somepm g` THEN
-  `support (fnpm ptpm (fnpm (cpmpm) apm)) fn A`
-     by (MATCH_MP_TAC rawfinite_support THEN SRW_TAC [][] THEN
-         METIS_TAC [])
-  THENL [
-    Q.UNABBREV_TAC `somepm` THEN
-    Q.ABBREV_TAC
-      `bigS = {u;v} UNION A UNION patoms p UNION allatoms t1 UNION
-              allatoms t2` THEN
-    `support (fnpm perm_of apm) f bigS /\ support (fnpm perm_of apm) g bigS`
-       by (SRW_TAC [][support_def, fnpm_def, FUN_EQ_THM, Abbr`f`, Abbr`bigS`,
-                      lamf_support_fresh, fn_support_fresh, Abbr`g`] THEN
-           ONCE_REWRITE_TAC [GSYM ptpm_sing_to_back] THEN
-           SRW_TAC [][] THEN SRW_TAC [][swapstr_def, allatoms_fresh]) THEN
-    `FINITE bigS` by SRW_TAC [][Abbr`bigS`] THEN
-    `FINITE (supp (fnpm perm_of apm) f) /\ FINITE (supp (fnpm perm_of apm) g)`
-       by METIS_TAC [SUBSET_FINITE, supp_smallest, fnpm_is_perm,
-                     perm_of_is_perm] THEN
-    `fcond apm f /\ fcond apm g`
-       by (SRW_TAC [][fcond_def] THENL [
-             Q.UNABBREV_TAC `f`,
-             Q.UNABBREV_TAC `g`
-           ] THEN
-           FIRST_X_ASSUM (ASSUME_TAC o GSYM o assert (is_forall o concl)) THEN
-           POP_ASSUM (fn th => REWRITE_TAC [th]) THEN
-           MATCH_MP_TAC cond16_implies_freshness_ok THENL [
-             MAP_EVERY Q.EXISTS_TAC [`A`, `A UNION allatoms t1`],
-             MAP_EVERY Q.EXISTS_TAC [`A`, `A UNION allatoms t2`]
-           ] THEN SRW_TAC [][] THEN
-           SRW_TAC [][support_def, fnpm_def, FUN_EQ_THM, fn_support_fresh,
-                      allatoms_fresh, is_perm_sing_inv] THEN
-           METIS_TAC []) THEN
-    `?z. ~(z IN bigS)` by METIS_TAC [NEW_def] THEN
-    `~(z IN supp (fnpm perm_of apm) f) /\ ~(z IN supp (fnpm perm_of apm) g)`
-        by METIS_TAC [supp_smallest, SUBSET_DEF, fnpm_is_perm,
-                      perm_of_is_perm] THEN
-    `(fresh apm f = f z) /\ (fresh apm g = g z)` by METIS_TAC [fresh_thm] THEN
-    SRW_TAC [][Abbr`f`, Abbr`g`, is_perm_flip_args, Abbr`bigS`] THEN
-    FULL_SIMP_TAC (srw_ss()) [],
+val termP0 = prove(
+  ``genind ^vp ^lp n t <=> ^termP t ∧ (n = 0)``,
+  EQ_TAC >> simp_tac (srw_ss()) [] >> strip_tac >>
+  qsuff_tac `n = 0` >- (strip_tac >> srw_tac [][]) >>
+  pop_assum mp_tac >>
+  Q.ISPEC_THEN `t` STRUCT_CASES_TAC gterm_cases >>
+  srw_tac [][genind_GVAR, genind_GLAM_eqn]);
 
-    Q.ABBREV_TAC
-      `bigS = {u;v} UNION A UNION patoms p UNION allatoms M1 UNION
-              allatoms M2` THEN
-    `support (fnpm perm_of somepm) f bigS /\
-     support (fnpm perm_of somepm) g bigS`
-       by (SRW_TAC [][support_def, fnpm_def, FUN_EQ_THM, Abbr`f`, Abbr`bigS`,
-                      limf_support_fresh, fn_support_fresh, Abbr`g`,
-                      Abbr`somepm`, is_perm_sing_inv] THEN
-           ONCE_REWRITE_TAC [GSYM ptpm_sing_to_back] THEN
-           SRW_TAC [][] THEN SRW_TAC [][swapstr_def, allatoms_fresh]) THEN
-    `FINITE bigS` by SRW_TAC [][Abbr`bigS`] THEN
-    `FINITE (supp (fnpm perm_of somepm) f) /\
-     FINITE (supp (fnpm perm_of somepm) g)`
-       by METIS_TAC [SUBSET_FINITE, supp_smallest, fnpm_is_perm,
-                     perm_of_is_perm] THEN
-    `is_perm somepm` by SRW_TAC [][Abbr`somepm`] THEN
-    `fcond somepm f /\ fcond somepm g`
-       by (SRW_TAC [][fcond_def] THENL [
-             Q.UNABBREV_TAC `f`,
-             Q.UNABBREV_TAC `g`
-           ] THEN
-           FIRST_X_ASSUM (ASSUME_TAC o GSYM o assert (is_forall o concl)) THEN
-           POP_ASSUM (fn th => REWRITE_TAC [th]) THEN
-           Q.UNABBREV_TAC `somepm` THEN
-           MATCH_MP_TAC cond16i_implies_freshness_ok THENL [
-             MAP_EVERY Q.EXISTS_TAC [`A UNION allatoms M1`,`A`],
-             MAP_EVERY Q.EXISTS_TAC [`A UNION allatoms M2`,`A`]
-           ] THEN SRW_TAC [][] THEN
-           SRW_TAC [][support_def, fnpm_def, FUN_EQ_THM, fn_support_fresh,
-                      allatoms_fresh, is_perm_sing_inv] THEN
-           METIS_TAC []) THEN
-    `?z. ~(z IN bigS)` by METIS_TAC [NEW_def] THEN
-    `~(z IN supp (fnpm perm_of somepm) f) /\
-     ~(z IN supp (fnpm perm_of somepm) g)`
-        by PROVE_TAC [supp_smallest, SUBSET_DEF, fnpm_is_perm,
-                      perm_of_is_perm] THEN
-    `(fresh somepm f = f z) /\ (fresh somepm g = g z)`
-       by METIS_TAC [fresh_thm] THEN
-    SRW_TAC [][Abbr`f`, Abbr`g`, is_perm_flip_args, Abbr`bigS`] THEN
-    FULL_SIMP_TAC (srw_ss()) []
-  ]);
-val _ = print "done\n"
+val LENGTH_NIL' =
+    CONV_RULE (BINDER_CONV (LAND_CONV (REWR_CONV EQ_SYM_EQ)))
+              listTheory.LENGTH_NIL
+val LENGTH1 = prove(
+  ``(1 = LENGTH l) ⇔ ∃e. l = [e]``,
+  Cases_on `l` >> srw_tac [][listTheory.LENGTH_NIL]);
+val LENGTH2 = prove(
+  ``(2 = LENGTH l) ⇔ ∃a b. l = [a;b]``,
+  Cases_on `l` >> srw_tac [][LENGTH1]);
 
-val better_lam_clause0 = prove(
-  ``^fndefn /\ ^ctxt00 /\ ^var_support_t /\ ^app_support_t /\ ^cond16 /\
-    ^cond16i /\
-    ~(z = v) /\ ~(z IN A) /\ ~(z IN allatoms t) ==>
-    (fn (lam z (ptpm [(z,v)] t)) [] = lamf z (fn (ptpm [(z,v)] t) []))``,
-  REPEAT STRIP_TAC THEN
-  `~(z IN fv t)` by METIS_TAC [SUBSET_DEF, fv_SUBSET_allatoms] THEN
-  `aeq (lam z (ptpm [(z,v)] t)) (lam v t)` by SRW_TAC [][lam_aeq_thm] THEN
-  `fn (lam z (ptpm [(z,v)] t)) [] = fn (lam v t) []`
-     by (MATCH_MP_TAC fn_respectful THEN SRW_TAC [][] THEN METIS_TAC []) THEN
-  POP_ASSUM SUBST1_TAC THEN SRW_TAC [][] THEN
-  `!t p1 p2. fn (ptpm p2 t) p1 = fn t (p1 ++ p2)`
-     by (MATCH_MP_TAC perms_move THEN SRW_TAC [][] THEN METIS_TAC []) THEN
-  POP_ASSUM (fn th => SIMP_TAC (srw_ss()) [th]) THEN
-  Q.MATCH_ABBREV_TAC `fresh apm f = lamf z (fn t [(z,v)])` THEN
-  `support (fnpm ptpm (fnpm (cpmpm) apm)) fn A`
-     by (MATCH_MP_TAC rawfinite_support THEN SRW_TAC [][] THEN
-         METIS_TAC []) THEN
-  Q.ABBREV_TAC `bigS = v INSERT A UNION allatoms t` THEN
-  `support (fnpm perm_of apm) f bigS`
-     by (SRW_TAC [][lamf_support_fresh, fn_support_fresh, support_def,
-                    fnpm_def, FUN_EQ_THM, Abbr`f`, listpm_def, pairpm_def,
-                    allatoms_fresh, Abbr`bigS`] THEN
-         SRW_TAC [][swapstr_def]) THEN
-  `FINITE bigS /\ ~(z IN bigS)` by SRW_TAC [][Abbr`bigS`] THEN
-  `~(z IN supp (fnpm perm_of apm) f) /\ FINITE (supp (fnpm perm_of apm) f)`
-      by METIS_TAC [supp_smallest, SUBSET_FINITE, SUBSET_DEF, fnpm_is_perm,
-                    perm_of_is_perm] THEN
-  Q_TAC SUFF_TAC `fcond apm f`
-        THEN1 (STRIP_TAC THEN
-               `fresh apm f = f z` by METIS_TAC [fresh_thm] THEN
-               SRW_TAC [][Abbr`f`]) THEN
-  SRW_TAC [][fcond_def] THEN
-  Q.UNABBREV_TAC `f` THEN
-  MATCH_MP_TAC ((REWRITE_RULE [listTheory.APPEND] o
-                 Q.INST [`pi` |-> `[]`]) cond16_implies_freshness_ok) THEN
-  MAP_EVERY Q.EXISTS_TAC [`A`, `A UNION allatoms t`] THEN
-  SRW_TAC [][] THENL [
-    SRW_TAC [][support_def, FUN_EQ_THM, fnpm_def, fn_support_fresh,
-               allatoms_fresh, is_perm_sing_inv],
-    METIS_TAC []
-  ]);
+val termP_elim = prove(
+  ``(∀g. ^termP g ⇒ P g) ⇔ (∀t. P (^term_REP_t t))``,
+  srw_tac [][EQ_IMP_THM] >- srw_tac [][genind_term_REP] >>
+  first_x_assum (qspec_then `^term_ABS_t g` mp_tac) >>
+  srw_tac [][repabs_pseudo_id]);
 
-val silly_new_lemma = prove(
-  ``~(x = NEW (x INSERT allatoms t)) /\
-    ~(NEW (x INSERT allatoms t) IN allatoms t)``,
-  Q.SPEC_THEN `x INSERT allatoms t` MP_TAC NEW_def THEN
-  SRW_TAC [][]);
+val termP_removal =
+    nomdatatype.termP_removal {repty = repty, termP = termP,
+                               elimth = termP_elim, tpm_def = tpm_def,
+                               absrep_id = absrep_id}
 
-val better_lam_clause =
-    (REWRITE_RULE [silly_new_lemma] o
-     Q.INST [`v` |-> `NEW (z INSERT allatoms t)`] o
-     REWRITE_RULE [] o
-     SIMP_RULE pure_ss [ptpm_sing_inv, allatoms_perm, perm_IN,
-                        perm_of_is_perm, listTheory.REVERSE_DEF,
-                        listTheory.APPEND, lswapstr_def, pairTheory.FST,
-                        pairTheory.SND, swapstr_def] o
-     Q.INST [`t` |-> `ptpm [(z,v)] t`]) better_lam_clause0
+val cons_info =
+    [{con_termP = VAR_termP, con_def = VAR_def},
+     {con_termP = APP_termP, con_def = SYM APP_def'},
+     {con_termP = LAM_termP, con_def = LAM_def},
+     {con_termP = LAMi_termP, con_def = LAMi_def}]
 
-val better_lami_clause0 = prove(
-  ``^fndefn /\ ^ctxt00 /\ ^var_support_t /\ ^app_support_t /\ ^cond16 /\
-    ^cond16i /\
-    ~(z = v) /\ ~(z IN A) /\ ~(z IN allatoms t) ==>
-    (fn (lami n z (ptpm [(z,v)] t) t') [] =
-       limf n z (fn (ptpm [(z,v)] t) []) (fn t' []))``,
-  REPEAT STRIP_TAC THEN
-  `~(z IN fv t)` by METIS_TAC [SUBSET_DEF, fv_SUBSET_allatoms] THEN
-  `aeq (lami n z (ptpm [(z,v)] t) t') (lami n v t t')`
-     by SRW_TAC [][lami_aeq_thm] THEN
-  `fn (lami n z (ptpm [(z,v)] t) t') [] = fn (lami n v t t') []`
-     by (MATCH_MP_TAC fn_respectful THEN SRW_TAC [][] THEN METIS_TAC []) THEN
-  POP_ASSUM SUBST1_TAC THEN SRW_TAC [][] THEN
-  `!t p1 p2. fn (ptpm p2 t) p1 = fn t (p1 ++ p2)`
-     by (MATCH_MP_TAC perms_move THEN SRW_TAC [][] THEN METIS_TAC []) THEN
-  POP_ASSUM (fn th => SIMP_TAC (srw_ss()) [th]) THEN
-  AP_THM_TAC THEN
-  Q.MATCH_ABBREV_TAC `fresh spm f = limf n z (fn t [(z,v)])` THEN
-  `support (fnpm ptpm (fnpm (cpmpm) apm)) fn A`
-     by (MATCH_MP_TAC rawfinite_support THEN SRW_TAC [][] THEN
-         METIS_TAC []) THEN
-  Q.ABBREV_TAC `bigS = v INSERT A UNION allatoms t` THEN
-  `support (fnpm perm_of spm) f bigS`
-     by (SRW_TAC [][limf_support_fresh, fn_support_fresh, support_def,
-                    fnpm_def, FUN_EQ_THM, Abbr`f`, listpm_def, pairpm_def,
-                    allatoms_fresh, Abbr`bigS`, Abbr`spm`,
-                    is_perm_sing_inv] THEN
-         SRW_TAC [][swapstr_def]) THEN
-  `FINITE bigS /\ ~(z IN bigS)` by SRW_TAC [][Abbr`bigS`] THEN
-  `~(z IN supp (fnpm perm_of spm) f) /\ FINITE (supp (fnpm perm_of spm) f)`
-      by PROVE_TAC [supp_smallest, SUBSET_FINITE, SUBSET_DEF, fnpm_is_perm,
-                    perm_of_is_perm] THEN
-  Q_TAC SUFF_TAC `fcond spm f`
-        THEN1 (STRIP_TAC THEN
-               `fresh spm f = f z` by METIS_TAC [fresh_thm] THEN
-               SRW_TAC [][Abbr`f`]) THEN
-  SRW_TAC [][fcond_def, Abbr`spm`] THEN
-  Q.UNABBREV_TAC `f` THEN
-  MATCH_MP_TAC ((REWRITE_RULE [listTheory.APPEND] o
-                 Q.INST [`pi` |-> `[]`]) cond16i_implies_freshness_ok) THEN
-  MAP_EVERY Q.EXISTS_TAC [`A UNION allatoms t`, `A`] THEN
-  SRW_TAC [][] THENL [
-    SRW_TAC [][support_def, FUN_EQ_THM, fnpm_def, fn_support_fresh,
-               allatoms_fresh, is_perm_sing_inv],
-    METIS_TAC []
-  ]);
+val parameter_tm_recursion = save_thm(
+  "parameter_ltm_recursion",
+  parameter_gtm_recursion
+        |> INST_TYPE [alpha |-> ``:unit + unit + num``, beta |-> ``:unit``,
+                      gamma |-> alpha]
+        |> Q.INST [`lf` |-> `^tlf`, `vf` |-> `^tvf`, `vp` |-> `^vp`,
+                   `lp` |-> `^lp`, `n` |-> `0`]
+        |> SIMP_RULE (srw_ss()) [sumTheory.FORALL_SUM, FORALL_AND_THM,
+                                 GSYM RIGHT_FORALL_IMP_THM, IMP_CONJ_THM,
+                                 GSYM RIGHT_EXISTS_AND_THM,
+                                 GSYM LEFT_EXISTS_AND_THM,
+                                 GSYM LEFT_FORALL_IMP_THM,
+                                 LIST_REL_CONS1, genind_GVAR,
+                                 genind_GLAM_eqn, NEWFCB_def,
+                                 sidecond_def, relsupp_def,
+                                 LENGTH_NIL', LENGTH1, LENGTH2]
+        |> ONCE_REWRITE_RULE [termP0]
+        |> SIMP_RULE (srw_ss() ++ DNF_ss) [LENGTH1, LENGTH2,
+                                           listTheory.LENGTH_NIL]
+        |> CONV_RULE (DEPTH_CONV termP_removal)
+        |> SIMP_RULE (srw_ss()) [GSYM supp_tpm, SYM term_REP_tpm]
+        |> UNDISCH
+        |> rpt_hyp_dest_conj
+        |> lift_exfunction {repabs_pseudo_id = repabs_pseudo_id,
+                            term_REP_t = term_REP_t,
+                            cons_info = cons_info}
+        |> DISCH_ALL
+        |> elim_unnecessary_atoms {finite_fv = FINITE_FV}
+                                  [ASSUME ``FINITE (A:string set)``]
+        |> UNDISCH_ALL |> DISCH_ALL
+        |> REWRITE_RULE [AND_IMP_INTRO]
+        |> CONV_RULE (LAND_CONV (REWRITE_CONV [GSYM CONJ_ASSOC]))
+        |> Q.INST [`vr'` |-> `vr`, `dpm` |-> `apm`])
 
-val better_lami_clause =
-    (REWRITE_RULE [silly_new_lemma] o
-     Q.INST [`v` |-> `NEW (z INSERT allatoms t)`] o
-     REWRITE_RULE [] o
-     SIMP_RULE pure_ss [ptpm_sing_inv, allatoms_perm, perm_IN,
-                        perm_of_is_perm, listTheory.REVERSE_DEF,
-                        listTheory.APPEND, lswapstr_def, pairTheory.FST,
-                        pairTheory.SND, swapstr_def] o
-     Q.INST [`t` |-> `ptpm [(z,v)] t`]) better_lami_clause0
+val FORALL_ONE = prove(
+  ``(!u:one. P u) = P ()``,
+  SRW_TAC [][EQ_IMP_THM, oneTheory.one_induction]);
+val FORALL_ONE_FN = prove(
+  ``(!uf : one -> 'a. P uf) = !a. P (\u. a)``,
+  SRW_TAC [][EQ_IMP_THM] THEN
+  POP_ASSUM (Q.SPEC_THEN `uf ()` MP_TAC) THEN
+  Q_TAC SUFF_TAC `(\y. uf()) = uf` THEN1 SRW_TAC [][] THEN
+  SRW_TAC [][FUN_EQ_THM, oneTheory.one]);
 
-val recursion0 = prove(
-  ``^cond16 /\ ^cond16i /\ ^ctxt00 /\ ^var_support_t /\ ^app_support_t ==>
-    ?f :: respects (aeq ===> (=)).
-        ((!s. f (var s) = vr s) /\
-         (!t1 t2. f (app t1 t2) = ap (f t1) (f t2)) /\
-         (!v t. ~(v IN A) ==> (f (lam v t) = lamf v (f t))) /\
-         (!n v t1 t2. ~(v IN A) ==>
-                      (f (lami n v t1 t2) = limf n v (f t1) (f t2)))) /\
-        (!x y t. ~(x IN A) /\ ~(y IN A) ==>
-                 (f (ptpm [(x,y)] t) = apm [(x,y)] (f t)))``,
-  REPEAT STRIP_TAC THEN
-  STRIP_ASSUME_TAC full THEN
-  SRW_TAC [][RES_EXISTS_THM, quotientTheory.IN_RESPECTS,
-             quotientTheory.FUN_REL] THEN
-  Q.EXISTS_TAC `\t. fn t []` THEN REPEAT CONJ_TAC THENL [
-    SRW_TAC [][] THEN MATCH_MP_TAC fn_respectful THEN
-    SRW_TAC [][] THEN METIS_TAC [],
-    SRW_TAC [][],
-    SRW_TAC [][],
-    REPEAT STRIP_TAC THEN BETA_TAC THEN
-    MATCH_MP_TAC better_lam_clause THEN SRW_TAC [][] THEN METIS_TAC [],
-    REPEAT STRIP_TAC THEN BETA_TAC THEN
-    MATCH_MP_TAC better_lami_clause THEN SRW_TAC [][] THEN METIS_TAC [],
-    `support (fnpm ptpm (fnpm cpmpm apm)) fn A`
-       by (MATCH_MP_TAC rawfinite_support THEN SRW_TAC [][] THEN
-           METIS_TAC []) THEN
-    ASSUME_TAC fn_support_fresh THEN
-    SRW_TAC [][]
+val EXISTS_ONE_FN = prove(
+  ``(?f : 'a -> one -> 'b. P f) = (?f : 'a -> 'b. P (\x u. f x))``,
+  SRW_TAC [][EQ_IMP_THM] THENL [
+    Q.EXISTS_TAC `\a. f a ()` THEN SRW_TAC [][] THEN
+    Q_TAC SUFF_TAC `(\x u. f x ()) = f` THEN1 SRW_TAC [][] THEN
+    SRW_TAC [][FUN_EQ_THM, oneTheory.one],
+    Q.EXISTS_TAC `\a u. f a` THEN SRW_TAC [][]
   ]);
 
-fun mk_def(s,t) =
-    {def_name = s ^ "_def", fixity = NONE, fname = s, func = t};
+val tm_recursion = save_thm(
+  "tm_recursion",
+  parameter_tm_recursion
+      |> Q.INST_TYPE [`:ρ` |-> `:unit`]
+      |> Q.INST [`ppm` |-> `K I`, `vr` |-> `λs u. vru s`,
+                 `ap` |-> `λr1 r2 t1 t2 u. apu (r1()) (r2()) t1 t2`,
+                 `lm` |-> `λr v t u. lmu (r()) v t`,
+                 `li` |-> `λr1 r2 n v t1 t2 u. liu (r1()) (r2()) n v t1 t2`]
+      |> SIMP_RULE (srw_ss()) [FORALL_ONE, FORALL_ONE_FN, EXISTS_ONE_FN,
+                               fnpm_def]
+      |> SIMP_RULE (srw_ss() ++ CONJ_ss) [supp_unitfn]
+      |> Q.INST [`apu` |-> `ap`, `lmu` |-> `lm`, `vru` |-> `vr`,
+                 `liu` |-> `li`])
 
-(* some trivialities that are either needed for the lifting, or which are
-   wanted to be part of it *)
-val lam_respects_aeq = prove(
-  ``!v t1 t2. aeq t1 t2 ==> aeq (lam v t1) (lam v t2)``,
-  SRW_TAC [][lam_aeq_thm]);
+val simple_induction = save_thm(
+  "simple_lterm_induction",
+  term_ind |> INST_TYPE [gamma |-> oneSyntax.one_ty]
+           |> SPECL [``\t:lterm u:unit. P t:bool``, ``\x:unit. {}:string set``]
+           |> SIMP_RULE bool_ss [FINITE_EMPTY, NOT_IN_EMPTY]
+           |> GEN ``P:lterm -> bool``)
 
-val app_respects_aeq = prove(
-  ``!M1 M2 N1 N2. aeq M1 M2 /\ aeq N1 N2 ==> aeq (app M1 N1) (app M2 N2)``,
-  SRW_TAC [][aeq_rules]);
+val lterm_bvc_induction = store_thm(
+  "lterm_bvc_induction",
+  ``!P X. FINITE X /\
+          (!s. P (VAR s)) /\
+          (!M N. P M /\ P N ==> P (APP M N)) /\
+          (!v M. ~(v IN X) /\ P M ==> P (LAM v M)) /\
+          (!n v M N. ~(v IN X) /\ ~(v IN FV N) /\ P M /\ P N ==>
+                     P (LAMi n v M N)) ==>
+          !t. P t``,
+  rpt gen_tac >> strip_tac >> ho_match_mp_tac (mkX_ind term_ind) >>
+  qexists_tac `X` >> srw_tac [][]);
 
-val var_respects_aeq = prove(
-  ``!s1 s2. (s1 = s2) ==> aeq (var s1) (var s2)``,
-  SRW_TAC [][]);
+val _ = Save_thm("ltpm_NIL", MATCH_MP is_perm_nil tpm_is_perm)
+val _ = Save_thm("ltpm_sing_inv", MATCH_MP is_perm_sing_inv tpm_is_perm)
+val _ = Save_thm("ltpm_id_front", MATCH_MP is_perm_id tpm_is_perm);
+val _ = Save_thm("ltpm_inverse", MATCH_MP is_perm_inverse tpm_is_perm)
+val FV_tpm = Save_thm("FV_" ^ tpm_name,
+                      ``x ∈ FV (ltpm p lt)``
+                      |> REWRITE_CONV [MATCH_MP perm_supp tpm_is_perm,
+                                       MATCH_MP perm_IN perm_of_is_perm]
+                      |> GEN_ALL)
+val tpm_flip_args = save_thm("ltpm_flip_args", MATCH_MP is_perm_flip_args tpm_is_perm)
+val ltpm_eql = save_thm("ltpm_eql", MATCH_MP is_perm_eql tpm_is_perm)
+val _ = save_thm("ltpm_eqr",
+                 CONV_RULE (BINOP_CONV (ONCE_REWRITE_CONV [EQ_SYM_EQ]))
+                           ltpm_eql)
 
-val lami_respects_aeq = prove(
-  ``!n v M1 M2 N1 N2. aeq M1 M2 /\ aeq N1 N2 ==>
-                      aeq (lami n v M1 N1) (lami n v M2 N2)``,
-  SRW_TAC [][lami_aeq_thm]);
-val aeq_app_11 = SIMP_RULE (srw_ss()) []
-                           (Q.INST [`v` |-> `app t' u'`] aeq_app_inversion)
-val aeq_var_11 = prove(
-  ``aeq (var s1) (var s2) = (s1 = s2)``,
-  ONCE_REWRITE_TAC [aeq_cases] THEN SRW_TAC [][] THEN METIS_TAC []);
+val tpm_fresh = store_thm(
+  "ltpm_fresh",
+  ``∀t:lterm x y. x ∉ FV t ∧ y ∉ FV t ==> (ltpm [(x,y)] t = t)``,
+  srw_tac [][supp_fresh])
 
+val _ = set_mapped_fixity {tok = "@@", fixity = Infixl 901, term_name = "APP"}
 
+val _ = Store_thm("lterm_distinct",
+  ``VAR s ≠ t @@ u ∧ VAR s ≠ LAM v t ∧ VAR s ≠ LAMi n v t u ∧
+    t @@ u ≠ LAM v t' ∧ t @@ u ≠ LAMi n v t1 t2 ∧
+    LAM v t ≠ LAMi n w t1 t2``,
+  srw_tac [][LAM_def, LAMi_def, VAR_def, APP_def, VAR_termP, APP_termP, LAM_termP,
+             LAMi_termP, term_ABS_pseudo11, gterm_distinct, GLAM_eq_thm])
 
+val _ = Store_thm("lterm_11",
+   ``((VAR s1 = VAR s2) <=> (s1 = s2)) ∧
+     ((t11 @@ t12 = t21 @@ t22) <=> (t11 = t21) ∧ (t12 = t22)) ∧
+     ((LAM v t1 = LAM v t2) <=> (t1 = t2)) ∧
+     ((LAMi n1 v t11 t12 = LAMi n2 v t21 t22) =
+         (n1 = n2) ∧ (t11 = t21) ∧ (t12 = t22))``,
+  srw_tac [][VAR_def, APP_def, LAM_def, LAM_termP, VAR_termP, APP_termP,
+             LAMi_def, LAMi_termP,
+             term_ABS_pseudo11, gterm_11, term_REP_11]);
 
-
-
-val [FV_thm, simple_lterm_induction, ltpm_thm, LAM_distinct, lterm_11,
-     LAM_eq_thm, LAMi_eq_thm, FRESH_swap0,
-     (* tpm_is_perm,*) ltm_recursion, FINITE_FV,
-     ltpm_sing_inv, ltpm_NIL, ltpm_flip_args, ltpm_id_front, ltpm_FV,
-     ltpm_inverse] =
-    quotient.define_equivalence_type
-    {
-     name = "lterm", equiv = aeq_equiv,
-     defs = map mk_def [("LAM", ``prelterm$lam``),
-                        ("APP", ``prelterm$app``),
-                        ("VAR", ``prelterm$var``),
-                        ("LAMi", ``prelterm$lami``),
-                        ("FV",  ``prelterm$fv``),
-                        ("ltpm", ``prelterm$ptpm``)],
-     welldefs = [lam_respects_aeq, app_respects_aeq, var_respects_aeq,
-                 lami_respects_aeq, aeq_fv,
-                 SIMP_RULE bool_ss [GSYM RIGHT_FORALL_IMP_THM] aeq_ptpm_lemma
-                 ],
-     old_thms = [fv_def, TypeBase.induction_of ``:prelterm$l0term``,
-                 ptpm_def,
-                 aeq_distinct, CONJ aeq_var_11 aeq_app_11,
-                 lam_aeq_thm, lami_aeq_thm, fresh_swap, (* ptpm_is_perm,*)
-                 Q.INST [`lamf` |-> `lm`, `limf` |-> `li`] recursion0,
-                 finite_fv,
-                 ptpm_sing_inv, ptpm_NIL, ptpm_flip_args, ptpm_id_front,
-                 ptpm_fv, ptpm_INVERSE]}
-
-val _ = List.app (fn s => remove_ovl_mapping s {Name = s, Thy = "prelterm"})
-                 ["app", "lam", "lami", "fv", "var", "ptpm"]
-
-val _ = Save_Thm("ltpm_NIL", ltpm_NIL)
-
-val ltpm_fresh = save_thm("ltpm_fresh", GSYM FRESH_swap0)
-
-val _ = Save_Thm("lterm_distinct", LAM_distinct);
-val _ = Save_Thm("lterm_11", lterm_11);
-val _ = Save_Thm("ltpm_thm", ltpm_thm);
-val _ = Save_Thm("FV_thm", FV_thm);
-val _ = Save_Thm("FINITE_FV", FINITE_FV);
-val _ = Save_Thm("ltpm_sing_inv", ltpm_sing_inv);
-val _ = Save_Thm("ltpm_id_front", ltpm_id_front);
-val _ = Save_Thm("ltpm_FV", ltpm_FV)
-val _ = Save_Thm("ltpm_inverse", ltpm_inverse)
-
-val _ = save_thm("lLAM_eq_thm", LAM_eq_thm);
-val _ = save_thm("lLAMi_eq_thm", LAMi_eq_thm);
-val _ = save_thm("ltm_recursion", ltm_recursion)
-
-val _ = save_thm("ltpm_flip_args", ltpm_flip_args)
-val _ = save_thm("simple_lterm_induction", simple_lterm_induction)
-
-val ltpm_is_perm = Store_Thm(
-  "ltpm_is_perm",
-  ``is_perm ltpm``,
-  SRW_TAC [][is_perm_def, FUN_EQ_THM, permeq_def] THEN
-  Q.ID_SPEC_TAC `x` THEN HO_MATCH_MP_TAC simple_lterm_induction THEN
-  SRW_TAC [][lswapstr_APPEND]);
-
-(* properties of ltpm *)
-val ltpm_eql = store_thm(
-  "ltpm_eql",
-  ``(ltpm pi t = u) = (t = ltpm (REVERSE pi) u)``,
-  METIS_TAC [ltpm_inverse])
-val ltpm_eqr = store_thm(
-  "ltpm_eqr",
-  ``(t = ltpm pi u) = (ltpm (REVERSE pi) t =  u)``,
-  METIS_TAC [ltpm_inverse])
-val ltpm_APPEND = store_thm(
+val tpm_APPEND = store_thm(
   "ltpm_APPEND",
   ``ltpm (p1 ++ p2) t = ltpm p1 (ltpm p2 t)``,
-  METIS_TAC [ltpm_is_perm, is_perm_def]);
+  METIS_TAC [tpm_is_perm, is_perm_def]);
 
+val term_CASES = save_thm(
+  tyname ^ "_CASES",
+  hd (Prim_rec.prove_cases_thm simple_induction))
 
 (* alpha-convertibility *)
 val ltpm_ALPHA = store_thm(
   "ltpm_ALPHA",
   ``~(v IN FV t) ==> (LAM u t = LAM v (ltpm [(v,u)] t))``,
-  SRW_TAC [boolSimps.CONJ_ss][LAM_eq_thm, ltpm_flip_args]);
+  SRW_TAC [boolSimps.CONJ_ss][LAM_eq_thm, tpm_flip_args]);
 val ltpm_ALPHAi = store_thm(
   "ltpm_ALPHAi",
   ``~(v IN FV t) ==> (LAMi n u t M = LAMi n v (ltpm [(v,u)] t) M)``,
-  SRW_TAC [boolSimps.CONJ_ss][LAMi_eq_thm, ltpm_flip_args]);
+  SRW_TAC [boolSimps.CONJ_ss][LAMi_eq_thm, tpm_flip_args]);
 
-val subst_lemma = prove(
-  ``~(y = v) /\ ~(x = v) /\ ~(x IN FV N) /\ ~(y IN FV N) ==>
-    (ltpm [(x,y)] (if swapstr x y s = v then N else VAR (swapstr x y s)) =
-     (if s = v then N else VAR s))``,
-  SRW_TAC [][swapstr_eq_left, ltpm_fresh]);
-
-val ltpm_apart = store_thm(
+val tpm_apart = store_thm(
   "ltpm_apart",
-  ``!t. ~(x IN FV t) /\ (y IN FV t) ==> ~(ltpm [(x,y)] t = t)``,
-  HO_MATCH_MP_TAC simple_lterm_induction THEN SRW_TAC [][] THENL [
-    METIS_TAC [],
-    METIS_TAC [],
-    SRW_TAC [][LAM_eq_thm] THEN
-    Cases_on `x = s` THEN SRW_TAC [][swapstr_def],
-    SRW_TAC [][swapstr_def, LAM_eq_thm],
-    SRW_TAC [][LAMi_eq_thm] THEN
-    Cases_on `x = s` THEN SRW_TAC [][swapstr_def],
-    SRW_TAC [][LAMi_eq_thm],
-    SRW_TAC [][LAMi_eq_thm, swapstr_def],
-    SRW_TAC [][LAMi_eq_thm, swapstr_def]
-  ]);
+  ``!t. x IN FV t /\ y NOTIN FV t ==> ~(ltpm [(x,y)] t = t)``,
+  srw_tac [][supp_apart])
 
-val supp_tpm = Store_Thm(
-  "supp_tpm",
-  ``supp ltpm = FV``,
-  ONCE_REWRITE_TAC [FUN_EQ_THM] THEN GEN_TAC THEN
-  MATCH_MP_TAC supp_unique_apart THEN SRW_TAC [][support_def, ltpm_fresh] THEN
-  METIS_TAC [ltpm_apart, ltpm_flip_args]);
+val tpm_COND = prove(
+  ``ltpm pi (if P then x else y) = if P then ltpm pi x else ltpm pi y``,
+  srw_tac [][]);
 
-val silly_lemma = prove(``?x. ~(x = y) /\ ~(x IN FV M)``,
-                        Q.SPEC_THEN `y INSERT FV M` MP_TAC NEW_def THEN
-                        SRW_TAC [][] THEN METIS_TAC [])
-
-val supp_partial_LAMi = prove(
-  ``supp (fnpm ltpm ltpm) (LAMi n a t) = FV t DELETE a``,
-  MATCH_MP_TAC supp_unique_apart THEN
-  SRW_TAC [][FUN_EQ_THM, support_def, fnpm_def, LAMi_eq_thm] THEN
-  SRW_TAC [][ltpm_fresh] THENL [
-    Cases_on `a = x` THEN1 SRW_TAC [][swapstr_def, ltpm_fresh] THEN
-    Cases_on `a = y` THEN SRW_TAC [][swapstr_def, ltpm_fresh],
-    SRW_TAC [boolSimps.CONJ_ss][swapstr_def],
-    SRW_TAC [boolSimps.CONJ_ss][swapstr_def, ltpm_flip_args],
-    METIS_TAC [ltpm_apart, ltpm_flip_args],
-    Cases_on `a = b` THEN SRW_TAC [][swapstr_def]
+val reordering = prove(
+  ``(?(f:lterm -> (string # lterm) -> lterm). P f) <=>
+    (?f. P (\M (v,N). f N v M))``,
+  EQ_TAC THEN STRIP_TAC THENL [
+    Q.EXISTS_TAC `λN x M. f M (x,N)` THEN SRW_TAC [][] THEN
+    CONV_TAC (REDEPTH_CONV pairLib.PAIRED_ETA_CONV) THEN
+    SRW_TAC [ETA_ss][],
+    Q.EXISTS_TAC `λM (x,N). f N x M` THEN SRW_TAC [][]
   ]);
 
 val subst_exists =
-    (SIMP_RULE (srw_ss()) [SKOLEM_THM, FORALL_AND_THM] o
-     Q.GEN `N` o Q.GEN `x` o
-     SIMP_RULE (srw_ss()) [support_def, FUN_EQ_THM, fnpm_def, subst_lemma,
-                           silly_lemma, supp_partial_LAMi] o
-     Q.INST [`A` |-> `x INSERT FV N`, `apm` |-> `ltpm`,
-             `vr` |-> `\s. if s = x then N else VAR s`,
-             `ap` |-> `APP`,
-             `lm` |-> `LAM`, `li` |-> `LAMi`] o
-     SPEC_ALL o
-     INST_TYPE [alpha |-> ``:lterm``]) ltm_recursion
+    parameter_tm_recursion
+        |> INST_TYPE [alpha |-> ``:lterm``, ``:ρ`` |-> ``:string # lterm``]
+        |> Q.INST [`A` |-> `{}`, `apm` |-> `ltpm`,
+             `ppm` |-> `pairpm lswapstr ltpm`,
+             `vr` |-> `\s (x,N). if s = x then N else VAR s`,
+             `ap` |-> `\r1 r2 t1 t2 p. APP (r1 p) (r2 p)`,
+             `lm` |-> `\r v t p. LAM v (r p)`,
+             `li` |-> `\r1 r2 n v t1 t2 p. LAMi n v (r1 p) (r2 p)`]
+        |> SIMP_RULE (srw_ss()) [tpm_COND, basic_swapTheory.swapstr_eq_left,
+                                 tpm_fresh, fnpm_def, supp_fresh,
+                                 is_perm_sing_inv, pairTheory.FORALL_PROD,
+                                 reordering]
+        |> elim_unnecessary_atoms {finite_fv = FINITE_FV} []
+        |> prove_alpha_fcbhyp {ppm = ``pairpm lswapstr ltpm``,
+                               alphas = [ltpm_ALPHA, ltpm_ALPHAi],
+                               rwts = []}
+        |> CONV_RULE (DEPTH_CONV
+                      (rename_vars [("p_1", "u"), ("p_2", "N")]))
 
 val SUB_DEF = new_specification("lSUB_DEF", ["SUB"], subst_exists)
 
-val _ = overload_on ("@@", ``APP``)
+val _ = add_rule {term_name = "SUB", fixity = Closefix,
+                  pp_elements = [TOK "[", TM, TOK "/", TM, TOK "]"],
+                  paren_style = OnlyIfNecessary,
+                  block_style = (AroundEachPhrase, (PP.INCONSISTENT, 2))};
 
-val lSUB_THM = Store_Thm(
-  "lSUB_THM",
-  ``([N/x] (VAR x) = N) /\ (~(x = y) ==> ([N/x] (VAR y) = VAR y)) /\
-    ([N/x] (M @@ P) = [N/x] M @@ [N/x] P) /\
-    (~(v IN FV N) /\ ~(v = x) ==> ([N/x] (LAM v M) = LAM v ([N/x] M))) /\
-    (~(v IN FV N) /\ ~(v = x) ==>
-        ([N/x] (LAMi n v M P) = LAMi n v ([N/x]M) ([N/x]P)))``,
-  SRW_TAC [][SUB_DEF]);
-val lSUB_VAR = store_thm(
-  "lSUB_VAR",
-  ``[N/x] (VAR s : lterm) = if s = x then N else VAR s``,
-  SRW_TAC [][SUB_DEF]);
-
-val lterm_bvc_induction = store_thm(
-  "lterm_bvc_induction",
-  ``!P X. FINITE X /\
-          (!s. P (VAR s)) /\
-          (!M N. P M /\ P N ==> P (APP M N)) /\
-          (!v M. ~(v IN X) /\ P M ==> P (LAM v M)) /\
-          (!n v M N. ~(v IN X) /\ ~(v IN FV N) /\ P M /\ P N ==>
-                     P (LAMi n v M N)) ==>
-          !t. P t``,
-  REPEAT GEN_TAC THEN STRIP_TAC THEN
-  Q_TAC SUFF_TAC `!t pi. P (ltpm pi t)` THEN1 METIS_TAC [ltpm_NIL] THEN
-  HO_MATCH_MP_TAC simple_lterm_induction THEN
-  REPEAT CONJ_TAC THEN TRY (SRW_TAC [][] THEN NO_TAC) THENL [
-    Q.X_GEN_TAC `t` THEN STRIP_TAC THEN
-    MAP_EVERY Q.X_GEN_TAC [`s`, `pi`] THEN
-    Q_TAC (NEW_TAC "z") `perm_of pi s INSERT FV (ltpm pi t) UNION X` THEN
-    Q_TAC SUFF_TAC `LAM (perm_of pi s) (ltpm pi t) =
-                    LAM z (ltpm [(z,perm_of pi s)] (ltpm pi t))`
-          THEN1 SRW_TAC [][GSYM ltpm_APPEND] THEN
-    SRW_TAC [][ltpm_ALPHA],
-    MAP_EVERY Q.X_GEN_TAC [`t1`, `t2`] THEN STRIP_TAC THEN
-    MAP_EVERY Q.X_GEN_TAC [`s`, `n`, `pi`] THEN
-    Q_TAC (NEW_TAC "z")
-          `perm_of pi s INSERT FV (ltpm pi t2) UNION X
-           UNION FV (ltpm pi t1)` THEN
-    Q_TAC SUFF_TAC
-          `LAMi n (perm_of pi s) (ltpm pi t1) (ltpm pi t2) =
-           LAMi n z (ltpm [(z,perm_of pi s)] (ltpm pi t1)) (ltpm pi t2)`
-          THEN1 SRW_TAC [][GSYM ltpm_APPEND] THEN
-    SRW_TAC [][ltpm_ALPHAi]
-  ]);
-
 val fresh_ltpm_subst = store_thm(
   "fresh_ltpm_subst",
   ``!t. ~(u IN FV t) ==> (ltpm [(u,v)] t = [VAR u/v] t)``,
   HO_MATCH_MP_TAC lterm_bvc_induction THEN Q.EXISTS_TAC `{u;v}` THEN
-  SRW_TAC [][] THEN SRW_TAC [][lSUB_VAR]);
+  SRW_TAC [][SUB_DEF]);
 
-val l14a = Store_Thm(
+val l14a = Store_thm(
   "l14a",
   ``!t : lterm. [VAR v/v] t = t``,
   HO_MATCH_MP_TAC lterm_bvc_induction THEN Q.EXISTS_TAC `{v}` THEN
-  SRW_TAC [][lSUB_VAR]);
+  SRW_TAC [][SUB_DEF]);
 
 val l14b = store_thm(
   "l14b",
@@ -1034,70 +479,34 @@
   HO_MATCH_MP_TAC lterm_bvc_induction THEN Q.EXISTS_TAC `v INSERT FV u` THEN
   SRW_TAC [][SUB_DEF]);
 
+val NOT_IN_FV_SUB_I = store_thm(
+  "NOT_IN_FV_SUB_I",
+  ``∀N u v M:lterm. v ∉ FV N ∧ v ≠ u ∧ v ∉ FV M ==> v ∉ FV ([N/u]M)``,
+  NTAC 3 gen_tac >> ho_match_mp_tac lterm_bvc_induction >>
+  qexists_tac `FV N ∪ {u;v}` >> srw_tac [][SUB_DEF]);
+
+val lSUB_THM = Store_thm(
+  "lSUB_THM",
+  ``([N/x] (VAR x) = N) /\ (~(x = y) ==> ([N/x] (VAR y) = VAR y)) /\
+    ([N/x] (M @@ P) = [N/x] M @@ [N/x] P) /\
+    (~(v IN FV N) /\ ~(v = x) ==> ([N/x] (LAM v M) = LAM v ([N/x] M))) /\
+    (~(v IN FV N) /\ ~(v = x) ==>
+        ([N/x] (LAMi n v M P) = LAMi n v ([N/x]M) ([N/x]P)))``,
+  SRW_TAC [][SUB_DEF]);
+val lSUB_VAR = store_thm(
+  "lSUB_VAR",
+  ``[N/x] (VAR s : lterm) = if s = x then N else VAR s``,
+  SRW_TAC [][SUB_DEF]);
+
 val l15a = store_thm(
   "l15a",
   ``!t:lterm. ~(v IN FV t) ==> ([u/v] ([VAR v/x] t) = [u/x] t)``,
   HO_MATCH_MP_TAC lterm_bvc_induction THEN Q.EXISTS_TAC `{x;v} UNION FV u` THEN
-  SRW_TAC [][SUB_DEF]);
+  SRW_TAC [][lSUB_VAR]);
 
-(* ----------------------------------------------------------------------
-    set up lterm recursion (where recursive arguments are still available)
-   ---------------------------------------------------------------------- *)
-
-val ltm_precursion_ex =
-  (UNDISCH o
-   Q.INST [`VR` |-> `vr`, `AP` |-> `ap`, `LM` |-> `lm`, `LI` |-> `li`,
-           `APM` |-> `apm`] o
-   SIMP_RULE (srw_ss()) [support_def, FUN_EQ_THM, fnpm_def, pairpm_def,
-                         pairTheory.FORALL_PROD,
-                         ASSUME ``is_perm (APM: 'a pm)``] o
-   Q.INST [`vr` |-> `\s. (VR s, VAR s)`,
-           `ap` |-> `\t u. (AP (FST t) (FST u) (SND t) (SND u),
-                            SND t @@ SND u)`,
-           `lm` |-> `\v t. (LM (FST t) v (SND t), LAM v (SND t))`,
-           `li` |-> `\n v t u. (LI (FST t) (FST u) n v (SND t) (SND u),
-                                LAMi n v (SND t) (SND u))`,
-           `apm` |-> `pairpm APM ltpm`] o
-   SPEC_ALL o
-   INST_TYPE [alpha |-> ``:'a # lterm``]) ltm_recursion
-
-val bod = #2 (dest_exists (concl ltm_precursion_ex))
-
-val ltm_snd_res = prove(
-  ``FINITE A ==> ^bod ==> !M. SND (f M) = M``,
-  NTAC 2 STRIP_TAC THEN HO_MATCH_MP_TAC lterm_bvc_induction THEN
-  Q.EXISTS_TAC `A` THEN SRW_TAC [][])
-
-val ltm_precursion_ex2 = prove(
-  ``FINITE A ==> ^bod ==>
-    ?f. ((!s. f (VAR s) = vr s) /\
-         (!M N. f (M @@ N) = ap (f M) (f N) M N) /\
-         (!v M. ~(v IN A) ==> (f (LAM v M) = lm (f M) v M)) /\
-         (!n v M N. ~(v IN A) ==>
-                       (f (LAMi n v M N) = li (f M) (f N) n v M N))) /\
-        (!x y t. ~(x IN A) /\ ~(y IN A) ==>
-                 (f (ltpm [(x,y)] t) = apm [(x,y)] (f t)))``,
-  REPEAT STRIP_TAC THEN Q.EXISTS_TAC `FST o f` THEN SRW_TAC [][] THEN
-  IMP_RES_TAC ltm_snd_res THEN SRW_TAC [][])
-
-val supp_lemma = prove(
-  ``is_perm apm ==> ((!x y t. f (ltpm [(x,y)] t) = apm [(x,y)] (f t)) =
-                     (!pi t. f (ltpm pi t) = apm pi (f t)))``,
-  SRW_TAC [][EQ_IMP_THM] THEN
-  Q.ID_SPEC_TAC `t`  THEN Induct_on `pi` THEN
-  ASM_SIMP_TAC (srw_ss()) [pairTheory.FORALL_PROD, is_perm_nil] THEN
-  MAP_EVERY Q.X_GEN_TAC [`a`,`b`,`M`] THEN
-  `ltpm ((a,b)::pi) M = ltpm [(a,b)] (ltpm pi M)`
-     by SRW_TAC [][GSYM tpm_APPEND] THEN SRW_TAC [][] THEN
-  SRW_TAC [][GSYM is_perm_decompose]);
-
 val ltm_recursion_nosideset = save_thm(
   "ltm_recursion_nosideset",
-  (SIMP_RULE (srw_ss()) [AND_IMP_INTRO, supp_lemma] o
-   Q.INST [`A` |-> `{}`] o
-   DISCH_ALL o
-   CHOOSE(``f:lterm -> 'a # lterm``, ltm_precursion_ex) o UNDISCH o
-   UNDISCH) ltm_precursion_ex2);
+  tm_recursion |> Q.INST [`A` |-> `{}`] |> REWRITE_RULE [NOT_IN_EMPTY, FINITE_EMPTY])
 
 val term_info_string =
     "local\n\
@@ -1107,7 +516,7 @@
     \    pm_rewrites = [],\n\
     \    pm_constant = ``labelledTerms$ltpm``,\n\
     \    fv_rewrites = [],\n\
-    \    fv_constant = ``labelledTerms$FV``,\n\
+    \    fv_constant = ``nomset$supp labelledTerms$ltpm``,\n\
     \    recursion_thm = SOME ltm_recursion_nosideset,\n\
     \    binders = [(``labelledTerms$LAM``, 0, ltpm_ALPHA),\n\
     \               (``labelledTerms$LAMi``, 1, ltpm_ALPHAi)]}\n\

Modified: HOL/examples/lambda/barendregt/normal_orderScript.sml
===================================================================
--- HOL/examples/lambda/barendregt/normal_orderScript.sml	2011-07-18 06:39:04 UTC (rev 9162)
+++ HOL/examples/lambda/barendregt/normal_orderScript.sml	2011-07-24 06:19:15 UTC (rev 9163)
@@ -419,7 +419,7 @@
   ``(noreduct (LAM v M) = OPTION_MAP (LAM v) (noreduct M)) ∧
     (noreduct (LAM v M @@ N) = SOME ([N/v]M)) ∧
     (¬is_abs M ⇒ (noreduct (M @@ N) =
-                  if bnf M then OPTION_MAP ((@@) M) (noreduct N)
+                  if bnf M then OPTION_MAP (APP M) (noreduct N)
                   else OPTION_MAP (λM'. M' @@ N) (noreduct M))) ∧
     (noreduct (VAR s) = NONE)``,
   SRW_TAC [][noreduct_def] THENL [
@@ -517,7 +517,7 @@
   "noredAPP'",
   ``~is_abs M ==> (noreduct (M @@ N) =
                      case noreduct M of
-                       NONE -> OPTION_MAP ((@@) M) (noreduct N)
+                       NONE -> OPTION_MAP (APP M) (noreduct N)
                      || SOME M' -> SOME (M' @@ N))``,
   SRW_TAC [][noreduct_thm, GSYM noreduct_bnf] THEN
   Cases_on `noreduct M` THEN FULL_SIMP_TAC (srw_ss()) []);

Deleted: HOL/examples/lambda/barendregt/preltermScript.sml
===================================================================
--- HOL/examples/lambda/barendregt/preltermScript.sml	2011-07-18 06:39:04 UTC (rev 9162)
+++ HOL/examples/lambda/barendregt/preltermScript.sml	2011-07-24 06:19:15 UTC (rev 9163)
@@ -1,580 +0,0 @@
-(* This is an -*- sml -*- file *)
-open HolKernel boolLib Parse bossLib BasicProvers metisLib NEWLib
-
-open basic_swapTheory pred_setTheory nomsetTheory termTheory
-
-val _ = new_theory "prelterm";
-
-val _ = Hol_datatype `l0term = var of string
-                              | app of l0term => l0term
-                              | lam of string => l0term
-                              | lami of num => string => l0term => l0term`
-
-fun Store_Thm(s, t, tac) = (store_thm(s,t,tac) before export_rewrites [s])
-fun Save_Thm(s, th) = (save_thm(s, th) before export_rewrites [s])
-
-val fv_def = Define`
-  (fv (var s) = {s}) /\
-  (fv (app t u) = fv t UNION fv u) /\
-  (fv (lam v t) = fv t DELETE v) /\
-  (fv (lami n v t1 t2) = (fv t1 DELETE v) UNION fv t2)
-`;
-val _ = export_rewrites ["fv_def"]
-
-val finite_fv = Store_Thm(
-  "finite_fv",
-  ``!t. FINITE (fv t)``,
-  Induct THEN SRW_TAC [][]);
-
-val ptpm_def = Define`
-  (ptpm p (var s) = var (perm_of p s)) /\
-  (ptpm p (app t u) = app (ptpm p t) (ptpm p u)) /\
-  (ptpm p (lam v t) = lam (perm_of p v) (ptpm p t)) /\
-  (ptpm p (lami n v t u) = lami n (perm_of p v) (ptpm p t) (ptpm p u))
-`;
-val _ = export_rewrites ["ptpm_def"]
-
-val ptpm_INVERSE = Store_Thm(
-  "ptpm_INVERSE",
-  ``!p. (ptpm p (ptpm (REVERSE p) t) = t) /\
-        (ptpm (REVERSE p) (ptpm p t) = t)``,
-  Induct_on `t` THEN SRW_TAC [][]);
-
-val ptpm_NIL = Store_Thm(
-  "ptpm_NIL",
-  ``ptpm [] t = t``,
-  Induct_on `t` THEN SRW_TAC [][]);
-
-val ptpm_id_front = Store_Thm(
-  "ptpm_id_front",
-  ``!x t. ptpm ((x,x)::t) M = ptpm t M``,
-  Induct_on `M` THEN SRW_TAC [][]);
-
-val ptpm_sing_inv = Store_Thm(
-  "ptpm_sing_inv",
-  ``ptpm [h] (ptpm [h] t) = t``,
-  METIS_TAC [ptpm_INVERSE, listTheory.REVERSE_DEF, listTheory.APPEND]);
-
-val ptpm_is_perm = Store_Thm(
-  "ptpm_is_perm",
-  ``is_perm ptpm``,
-  SRW_TAC [][is_perm_def, FUN_EQ_THM, permeq_def] THENL [
-    Induct_on `x` THEN SRW_TAC [][lswapstr_APPEND],
-    Induct_on `x` THEN SRW_TAC [][]
-  ]);
-
-val ptpm_fv = Store_Thm(
-  "ptpm_fv",
-  ``fv (ptpm p t) = setpm perm_of p (fv t)``,
-  Induct_on `t` THEN
-  SRW_TAC [][perm_EMPTY, perm_INSERT, perm_UNION, perm_DELETE]);
-
-val allatoms_def = Define`
-  (allatoms (var s) = {s}) /\
-  (allatoms (app t1 t2) = allatoms t1 UNION allatoms t2) /\
-  (allatoms (lam v t) = v INSERT allatoms t) /\
-  (allatoms (lami n v t u) = v INSERT allatoms t UNION allatoms u)
-`;
-val _ = export_rewrites ["allatoms_def"]
-
-val allatoms_finite = Store_Thm(
-  "allatoms_finite",
-  ``FINITE (allatoms t)``,
-  Induct_on `t` THEN SRW_TAC [][]);
-
-val allatoms_supports = store_thm(
-  "allatoms_supports",
-  ``support ptpm t (allatoms t)``,
-  SRW_TAC [][support_def] THEN Induct_on `t` THEN
-  SRW_TAC [][swapstr_def]);
-
-val allatoms_fresh = store_thm(
-  "allatoms_fresh",
-  ``!x y. ~(x IN allatoms t) /\ ~(y IN allatoms t) ==> (ptpm [(x,y)] t = t)``,
-  METIS_TAC [allatoms_supports, support_def]);
-
-val allatoms_apart = store_thm(
-  "allatoms_apart",
-  ``a IN allatoms t /\ ~(b IN allatoms t) ==> ~(ptpm [(a,b)] t = t)``,
-  Induct_on `t` THEN SRW_TAC [][swapstr_def] THEN
-  METIS_TAC []);
-
-val allatoms_supp = store_thm(
-  "allatoms_supp",
-  ``supp ptpm t = allatoms t``,
-  MATCH_MP_TAC supp_unique_apart THEN
-  SRW_TAC [][allatoms_supports, allatoms_apart]);
-
-val allatoms_perm = store_thm(
-  "allatoms_perm",
-  ``allatoms (ptpm p t) = setpm perm_of p (allatoms t)``,
-  Induct_on `t` THEN SRW_TAC [][perm_INSERT, perm_EMPTY, perm_UNION]);
-
-val (aeq_rules, aeq_ind, aeq_cases) = Hol_reln`
-  (!s. aeq (var s) (var s)) /\
-  (!t1 t2 u1 u2. aeq t1 t2 /\ aeq u1 u2 ==> aeq (app t1 u1) (app t2 u2)) /\
-  (!u v z t1 t2.
-      aeq (ptpm [(u,z)] t1) (ptpm [(v,z)] t2) /\
-      ~(z IN allatoms t1) /\ ~(z IN allatoms t2) /\ ~(z = u) /\ ~(z = v) ==>
-               aeq (lam u t1) (lam v t2)) /\
-  (!u v z n t1 t2 u1 u2.
-      aeq (ptpm [(u,z)] t1) (ptpm [(v,z)] t2) /\ aeq u1 u2 /\
-      ~(z IN allatoms t1) /\ ~(z IN allatoms t2) /\ ~(z = u) /\ ~(z = v) ==>
-      aeq (lami n u t1 u1) (lami n v t2 u2))
-`;
-
-val aeq_app = List.nth(CONJUNCTS aeq_rules, 1)
-val aeq_lam = List.nth(CONJUNCTS aeq_rules, 2)
-val aeq_lami = List.nth (CONJUNCTS aeq_rules, 3)
-
-val aeq_distinct = store_thm(
-  "aeq_distinct",
-  ``~(aeq (var s) (app t u)) /\ ~(aeq (var s) (lam v t)) /\
-    ~(aeq (var s) (lami n v t u)) /\
-    ~(aeq (app t u) (lam v t')) /\ ~(aeq (app t u) (lami n v t' u')) /\
-    ~(aeq (lam v t) (lami n v' t' u'))``,
-  ONCE_REWRITE_TAC [aeq_cases] THEN SRW_TAC [][]);
-
-val ptpm_sing_to_back = store_thm(
-  "ptpm_sing_to_back",
-  ``ptpm [(perm_of p u, perm_of p v)] (ptpm p t) = ptpm p (ptpm [(u,v)] t)``,
-  Induct_on `t` THEN SRW_TAC [][GSYM perm_of_swapstr]);
-
-val aeq_ptpm_lemma = store_thm(
-  "aeq_ptpm_lemma",
-  ``!t u. aeq t u ==> !p. aeq (ptpm p t) (ptpm p u)``,
-  HO_MATCH_MP_TAC aeq_ind THEN SRW_TAC [][aeq_rules] THENL [
-    MATCH_MP_TAC aeq_lam THEN
-    Q.EXISTS_TAC `perm_of p z` THEN
-    SRW_TAC [][allatoms_perm, ptpm_sing_to_back, perm_IN],
-    MATCH_MP_TAC aeq_lami THEN
-    Q.EXISTS_TAC `perm_of p z` THEN
-    SRW_TAC [][allatoms_perm, ptpm_sing_to_back, perm_IN]
-  ]);
-
-val aeq_ptpm_eqn = store_thm(
-  "aeq_ptpm_eqn",
-  ``aeq (ptpm p t) u = aeq t (ptpm (REVERSE p) u)``,
-  METIS_TAC [aeq_ptpm_lemma, ptpm_INVERSE]);
-
-val fv_SUBSET_allatoms = store_thm(
-  "fv_SUBSET_allatoms",
-  ``!t. fv t SUBSET allatoms t``,
-  SIMP_TAC (srw_ss()) [SUBSET_DEF] THEN Induct THEN SRW_TAC [][] THEN
-  METIS_TAC []);
-
-val aeq_fv = store_thm(
-  "aeq_fv",
-  ``!t u. aeq t u ==> (fv t = fv u)``,
-  HO_MATCH_MP_TAC aeq_ind THEN SRW_TAC [][EXTENSION, ptpm_fv, perm_IN] THENL [
-    Cases_on `x = u` THEN SRW_TAC [][] THENL [
-      Cases_on `u = v` THEN SRW_TAC [][] THEN
-      FIRST_X_ASSUM (Q.SPEC_THEN `swapstr v z u` (MP_TAC o SYM)) THEN
-      SRW_TAC [][] THEN SRW_TAC [][swapstr_def] THEN
-      METIS_TAC [fv_SUBSET_allatoms, SUBSET_DEF],
-      Cases_on `x = v` THEN SRW_TAC [][] THENL [
-        FIRST_X_ASSUM (Q.SPEC_THEN `swapstr u z v` MP_TAC) THEN
-        SRW_TAC [][] THEN SRW_TAC [][swapstr_def] THEN
-        METIS_TAC [fv_SUBSET_allatoms, SUBSET_DEF],
-        Cases_on `z = x` THEN SRW_TAC [][] THENL [
-          METIS_TAC [fv_SUBSET_allatoms, SUBSET_DEF],
-          FIRST_X_ASSUM (Q.SPEC_THEN `x` MP_TAC) THEN
-          SRW_TAC [][swapstr_def]
-        ]
-      ]
-    ],
-    Cases_on `x = u` THEN SRW_TAC [][] THENL [
-      Cases_on `u = v` THEN SRW_TAC [][] THEN
-      Q.PAT_ASSUM `!x. swapstr u z x IN fv t1 <=> Z`
-                  (Q.SPEC_THEN `swapstr v z u` (MP_TAC o SYM)) THEN
-      SRW_TAC [][] THEN SRW_TAC [][swapstr_def] THEN
-      METIS_TAC [fv_SUBSET_allatoms, SUBSET_DEF],
-      Cases_on `x = v` THEN SRW_TAC [][] THENL [
-        Q.PAT_ASSUM `!x. swapstr u z x IN fv t1 <=> Z`
-                    (Q.SPEC_THEN `swapstr u z v` MP_TAC) THEN
-        SRW_TAC [][] THEN SRW_TAC [][swapstr_def] THEN
-        METIS_TAC [fv_SUBSET_allatoms, SUBSET_DEF],
-        Cases_on `z = x` THEN SRW_TAC [][] THENL [
-          METIS_TAC [fv_SUBSET_allatoms, SUBSET_DEF],
-          Q.PAT_ASSUM `!x. swapstr u z x IN fv t1 <=> Z`
-                      (Q.SPEC_THEN `x` MP_TAC) THEN
-          SRW_TAC [][swapstr_def]
-        ]
-      ]
-    ]
-  ]);
-
-
-val aeq_refl = Store_Thm(
-  "aeq_refl",
-  ``aeq t t``,
-  Induct_on `t` THEN ASM_SIMP_TAC (srw_ss())[aeq_rules] THENL [
-    Q.X_GEN_TAC `s` THEN
-    MATCH_MP_TAC aeq_lam THEN SRW_TAC [][aeq_ptpm_eqn] THEN
-    Q.SPEC_THEN `s INSERT allatoms t` MP_TAC NEW_def THEN SRW_TAC [][] THEN
-    METIS_TAC [],
-    Q.X_GEN_TAC `s` THEN GEN_TAC THEN
-    MATCH_MP_TAC aeq_lami THEN SRW_TAC [][aeq_ptpm_eqn] THEN
-    Q.SPEC_THEN `s INSERT allatoms t` MP_TAC NEW_def THEN SRW_TAC [][] THEN
-    METIS_TAC []
-  ]);
-
-val ptpm_flip_args = store_thm(
-  "ptpm_flip_args",
-  ``!x y t. ptpm ((y,x)::t) M = ptpm ((x,y)::t) M``,
-  Induct_on `M` THEN SRW_TAC [][]);
-
-val aeq_sym = store_thm(
-  "aeq_sym",
-  ``!t u. aeq t u ==> aeq u t``,
-  HO_MATCH_MP_TAC aeq_ind THEN SRW_TAC [][aeq_rules] THEN
-  METIS_TAC [aeq_lam, aeq_lami]);
-
-val aeq_app_inversion = store_thm(
-  "aeq_app_inversion",
-  ``aeq (app t u) v = ?t' u'. (v = app t' u') /\
-                              aeq t t' /\ aeq u u'``,
-  SRW_TAC [][Once aeq_cases, SimpLHS]);
-
-val aeq_app_11 = SIMP_RULE (srw_ss()) []
-                           (Q.INST [`v` |-> `app t' u'`] aeq_app_inversion)
-val aeq_var_11 = prove(
-  ``aeq (var s1) (var s2) = (s1 = s2)``,
-  ONCE_REWRITE_TAC [aeq_cases] THEN SRW_TAC [][] THEN METIS_TAC []);
-
-val aeq_lam_inversion = store_thm(
-  "aeq_lam_inversion",
-  ``aeq (lam v M) N = ?v' M' z. (N = lam v' M') /\
-                                ~(z = v') /\ ~(z = v) /\ ~(z IN allatoms M) /\
-                                ~(z IN allatoms M') /\
-                                aeq (ptpm [(v,z)] M) (ptpm [(v',z)] M')``,
-  SRW_TAC [][Once aeq_cases, SimpLHS] THEN METIS_TAC []);
-
-val aeq_lami_inversion = store_thm(
-  "aeq_lami_inversion",
-  ``aeq (lami n v M N) P =
-      ?v' M' N' z. (P = lami n v' M' N') /\
-                   ~(z = v') /\ ~(z = v) /\
-                   ~(z IN allatoms M) /\ ~(z IN allatoms M') /\
-                   aeq (ptpm [(v,z)] M) (ptpm [(v',z)] M') /\
-                   aeq N N'``,
-  SRW_TAC [][Once aeq_cases, SimpLHS] THEN METIS_TAC []);
-
-val aeq_strong_ind = IndDefLib.derive_strong_induction (aeq_rules, aeq_ind)
-
-(* proof follows that on p169 of Andy Pitts, Information and Computation 186
-   article: Nominal logic, a first order theory of names and binding *)
-val aeq_trans = store_thm(
-  "aeq_trans",
-  ``!t u v. aeq t u /\ aeq u v ==> aeq t v``,
-  Q_TAC SUFF_TAC `!t u. aeq t u ==> !v. aeq u v ==> aeq t v`
-        THEN1 METIS_TAC [] THEN
-  HO_MATCH_MP_TAC aeq_ind THEN REPEAT CONJ_TAC THENL [
-    SRW_TAC [][],
-    SRW_TAC [][aeq_app_inversion],
-    Q_TAC SUFF_TAC
-          `!a a' b t t'.
-             (!t''. aeq (ptpm [(a',b)] t') t'' ==> aeq (ptpm [(a,b)] t) t'') /\
-             ~(b IN allatoms t) /\ ~(b IN allatoms t') /\
-             ~(b = a) /\ ~(b = a') ==>
-             !t''. aeq (lam a' t') t'' ==> aeq (lam a t) t''`
-          THEN1 METIS_TAC [] THEN
-    REPEAT GEN_TAC THEN STRIP_TAC THEN GEN_TAC THEN
-    SIMP_TAC (srw_ss()) [Once aeq_lam_inversion, SimpL ``(==>)``] THEN
-    DISCH_THEN
-      (Q.X_CHOOSE_THEN `a''`
-         (Q.X_CHOOSE_THEN `t'''`
-              (Q.X_CHOOSE_THEN `c` STRIP_ASSUME_TAC))) THEN
-    `?d. ~(d = a) /\ ~(d = a') /\ ~(d = a'') /\ ~(d = b) /\ ~(d = c) /\
-         ~(d IN allatoms t) /\ ~(d IN allatoms t') /\ ~(d IN allatoms t'')`
-       by (Q.SPEC_THEN `{a;a';a'';b;c} UNION allatoms t UNION allatoms t' UNION
-                        allatoms t''` MP_TAC NEW_def THEN
-           SRW_TAC [][] THEN METIS_TAC []) THEN
-    `!t''. aeq (ptpm [(b,d)] (ptpm [(a',b)] t')) (ptpm [(b,d)] t'') ==>
-           aeq (ptpm [(b,d)] (ptpm [(a,b)] t)) (ptpm [(b,d)] t'')`
-       by FULL_SIMP_TAC (srw_ss()) [aeq_ptpm_eqn] THEN
-    POP_ASSUM (Q.SPEC_THEN `ptpm [(b,d)] t''`
-                           (ASSUME_TAC o Q.GEN `t''` o
-                            SIMP_RULE (srw_ss()) [])) THEN
-    POP_ASSUM (MP_TAC o
-               ONCE_REWRITE_RULE [GSYM ptpm_sing_to_back]) THEN
-    `!x y t. ~(x IN allatoms t) /\ ~(y IN allatoms t) ==>
-             (ptpm [(x,y)] t = t)`
-       by METIS_TAC [allatoms_supports, support_def] THEN
-    SRW_TAC [][swapstr_def] THEN
-    `aeq (ptpm [(c,d)] (ptpm [(a',c)] t'))
-         (ptpm [(c,d)] (ptpm [(a'',c)] t'''))`
-       by FULL_SIMP_TAC (srw_ss()) [aeq_ptpm_eqn] THEN
-    POP_ASSUM (MP_TAC o ONCE_REWRITE_RULE [GSYM ptpm_sing_to_back]) THEN
-    `~(d IN allatoms t''')` by FULL_SIMP_TAC (srw_ss()) [allatoms_def] THEN
-    SRW_TAC [][swapstr_def] THEN
-    `aeq (ptpm [(a,d)] t) (ptpm [(a'',d)] t''')` by METIS_TAC [] THEN
-    METIS_TAC [aeq_lam],
-
-    Q_TAC SUFF_TAC
-          `!a a' n b t t' u u'.
-             (!t''. aeq (ptpm [(a',b)] t') t'' ==> aeq (ptpm [(a,b)] t) t'') /\
-             ~(b IN allatoms t) /\ ~(b IN allatoms t') /\
-             ~(b = a) /\ ~(b = a') /\
-             (!u''. aeq u' u'' ==> aeq u u'') ==>
-             !t''. aeq (lami n a' t' u') t'' ==> aeq (lami n a t u) t''`
-           THEN1 (STRIP_TAC THEN REPEAT GEN_TAC THEN STRIP_TAC THEN
-                  FIRST_X_ASSUM MATCH_MP_TAC THEN METIS_TAC []) THEN
-    REPEAT GEN_TAC THEN STRIP_TAC THEN GEN_TAC THEN
-    SIMP_TAC (srw_ss()) [aeq_lami_inversion, SimpL ``(==>)``] THEN
-    DISCH_THEN
-      (Q.X_CHOOSE_THEN `a''`
-         (Q.X_CHOOSE_THEN `t'''`
-            (Q.X_CHOOSE_THEN `u''`
-               (Q.X_CHOOSE_THEN `c` STRIP_ASSUME_TAC)))) THEN
-    `?d. ~(d = a) /\ ~(d = a') /\ ~(d = a'') /\ ~(d = b) /\ ~(d = c) /\
-         ~(d IN allatoms t) /\ ~(d IN allatoms t') /\ ~(d IN allatoms t'')`
-       by (Q.SPEC_THEN `{a;a';a'';b;c} UNION allatoms t UNION allatoms t' UNION
-                        allatoms t''` MP_TAC NEW_def THEN SRW_TAC [][] THEN
-           METIS_TAC []) THEN
-    `!t''. aeq (ptpm [(b,d)] (ptpm [(a',b)] t')) (ptpm [(b,d)] t'') ==>
-           aeq (ptpm [(b,d)] (ptpm [(a,b)] t)) (ptpm [(b,d)] t'')`
-       by FULL_SIMP_TAC (srw_ss()) [aeq_ptpm_eqn] THEN
-    POP_ASSUM (Q.SPEC_THEN `ptpm [(b,d)] t''`
-                           (ASSUME_TAC o Q.GEN `t''` o
-                            SIMP_RULE (srw_ss()) [])) THEN
-    POP_ASSUM (MP_TAC o
-               ONCE_REWRITE_RULE [GSYM ptpm_sing_to_back]) THEN
-    SRW_TAC [][allatoms_fresh, swapstr_def] THEN
-    `aeq (ptpm [(c,d)] (ptpm [(a',c)] t'))
-         (ptpm [(c,d)] (ptpm [(a'',c)] t'''))`
-       by FULL_SIMP_TAC (srw_ss()) [aeq_ptpm_eqn] THEN
-    POP_ASSUM (MP_TAC o ONCE_REWRITE_RULE [GSYM ptpm_sing_to_back]) THEN
-    `~(d IN allatoms t''')` by FULL_SIMP_TAC (srw_ss()) [allatoms_def] THEN
-    SRW_TAC [][allatoms_fresh, swapstr_def] THEN
-    `aeq (ptpm [(a,d)] t) (ptpm [(a'',d)] t''')` by METIS_TAC [] THEN
-    METIS_TAC [aeq_lami]
-  ]);
-
-open relationTheory
-val aeq_equiv = store_thm(
-  "aeq_equiv",
-  ``!t1 t2. aeq t1 t2 = (aeq t1 = aeq t2)``,
-  SIMP_TAC (srw_ss()) [GSYM ALT_equivalence, equivalence_def, reflexive_def,
-                       symmetric_def, transitive_def] THEN
-  METIS_TAC [aeq_trans, aeq_sym]);
-
-val swapstr_safe = prove(
-  ``(swapstr x y x = y) /\ (swapstr y x x = y)``,
-  SRW_TAC [][swapstr_def]);
-
-val alt_aeq_lam = store_thm(
-  "alt_aeq_lam",
-  ``(!z. ~(z IN allatoms t1) /\ ~(z IN allatoms t2) /\ ~(z = u) /\ ~(z = v) ==>
-         aeq (ptpm [(u,z)] t1) (ptpm [(v,z)] t2)) ==>
-    aeq (lam u t1) (lam v t2)``,
-  STRIP_TAC THEN MATCH_MP_TAC aeq_lam THEN
-  `?z. ~(z IN allatoms t1) /\ ~(z IN allatoms t2) /\ ~(z = u) /\ ~(z = v)`
-      by (Q.SPEC_THEN `allatoms t1 UNION allatoms t2 UNION {u;v}`
-                      MP_TAC NEW_def THEN SRW_TAC [][] THEN METIS_TAC []) THEN
-  METIS_TAC []);
-
-val alt_aeq_lami = store_thm(
-  "alt_aeq_lami",
-  ``(!z. ~(z IN allatoms t1) /\ ~(z IN allatoms t2) /\ ~(z = u) /\ ~(z = v) ==>
-         aeq (ptpm [(u,z)] t1) (ptpm [(v,z)] t2)) /\ aeq u1 u2 ==>
-    aeq (lami n u t1 u1) (lami n v t2 u2)``,
-  STRIP_TAC THEN MATCH_MP_TAC aeq_lami THEN
-  `?z. ~(z IN allatoms t1) /\ ~(z IN allatoms t2) /\ ~(z = u) /\ ~(z = v)`
-      by (Q.SPEC_THEN `allatoms t1 UNION allatoms t2 UNION {u;v}`
-                      MP_TAC NEW_def THEN SRW_TAC [][] THEN METIS_TAC []) THEN
-  METIS_TAC []);
-
-val fresh_swap = store_thm(
-  "fresh_swap",
-  ``!x y. ~(x IN fv t) /\ ~(y IN fv t) ==> aeq t (ptpm [(x, y)] t)``,
-  SIMP_TAC (srw_ss()) [] THEN Induct_on `t` THEN
-  ASM_SIMP_TAC (srw_ss()) [aeq_rules] THENL [
-    Q.X_GEN_TAC `s` THEN
-    REPEAT STRIP_TAC THEN SRW_TAC [][] THEN
-    MATCH_MP_TAC alt_aeq_lam THEN REPEAT STRIP_TAC THEN
-    `~(z IN fv t)` by METIS_TAC [SUBSET_DEF, fv_SUBSET_allatoms]
-    THENL [
-      Cases_on `s = x` THEN FULL_SIMP_TAC (srw_ss()) [] THENL [
-        ASM_SIMP_TAC (srw_ss()) [Once (GSYM ptpm_sing_to_back)] THEN
-        SRW_TAC [][aeq_ptpm_eqn, swapstr_def],
-        ALL_TAC
-      ] THEN Cases_on `s = y` THENL [
-        FULL_SIMP_TAC (srw_ss()) [] THEN
-        ONCE_REWRITE_TAC [GSYM ptpm_sing_to_back] THEN
-        SRW_TAC [][swapstr_def, ptpm_flip_args, aeq_ptpm_eqn],
-        SRW_TAC [][swapstr_def, aeq_ptpm_eqn]
-      ],
-      Cases_on `s = x` THEN1 SRW_TAC [][] THEN
-      ONCE_REWRITE_TAC [GSYM ptpm_sing_to_back] THEN
-      SRW_TAC [][swapstr_def, ptpm_flip_args, aeq_ptpm_eqn],
-      Cases_on `s = y` THEN1 SRW_TAC [][] THEN
-      ONCE_REWRITE_TAC [GSYM ptpm_sing_to_back] THEN
-      SRW_TAC [][swapstr_def, aeq_ptpm_eqn]
-    ],
-    Q.X_GEN_TAC `s` THEN
-    REPEAT STRIP_TAC THEN SRW_TAC [][] THEN
-    MATCH_MP_TAC alt_aeq_lami THEN REPEAT STRIP_TAC THEN
-    TRY (FIRST_X_ASSUM MATCH_MP_TAC THEN SRW_TAC [][] THEN NO_TAC) THEN
-    `~(z IN fv t)` by METIS_TAC [SUBSET_DEF, fv_SUBSET_allatoms]
-    THENL [
-      Cases_on `s = x` THEN FULL_SIMP_TAC (srw_ss()) [] THENL [
-        ONCE_REWRITE_TAC [GSYM ptpm_sing_to_back] THEN
-        SRW_TAC [][swapstr_def, aeq_ptpm_eqn],
-        ALL_TAC
-      ] THEN Cases_on `s = y` THENL [
-        FULL_SIMP_TAC (srw_ss()) [] THEN
-        ONCE_REWRITE_TAC [GSYM ptpm_sing_to_back] THEN
-        SRW_TAC [][swapstr_def, aeq_ptpm_eqn, ptpm_flip_args],
-        SRW_TAC [][swapstr_def, aeq_ptpm_eqn]
-      ],
-      Cases_on `s = x` THEN1 SRW_TAC [][] THEN
-      ONCE_REWRITE_TAC [GSYM ptpm_sing_to_back] THEN
-      SRW_TAC [][swapstr_def, ptpm_flip_args, aeq_ptpm_eqn],
-      Cases_on `s = y` THEN1 SRW_TAC [][] THEN
-      ONCE_REWRITE_TAC [GSYM ptpm_sing_to_back] THEN
-      SRW_TAC [][swapstr_def, aeq_ptpm_eqn]
-    ]
-  ]);
-
-val lam_aeq_thm = store_thm(
-  "lam_aeq_thm",
-  ``aeq (lam u t1) (lam v t2) <=>
-       u = v ∧ aeq t1 t2 ∨ u ≠ v ∧ u ∉ fv t2 ∧ aeq t1 (ptpm [(u,v)] t2)``,
-  SIMP_TAC (srw_ss()) [EQ_IMP_THM, DISJ_IMP_THM] THEN REPEAT CONJ_TAC THENL [
-    SRW_TAC [][aeq_lam_inversion] THEN
-    `~(z IN fv t1) /\ ~(z IN fv t2)`
-       by METIS_TAC [SUBSET_DEF, fv_SUBSET_allatoms] THEN
-    Cases_on `u = v` THEN1 FULL_SIMP_TAC (srw_ss()) [aeq_ptpm_eqn] THEN
-    `~(u IN fv t2)`
-        by (STRIP_TAC THEN
-            `u IN fv (ptpm [(v,z)] t2)`
-               by SRW_TAC [][ptpm_fv, perm_IN, swapstr_def] THEN
-            `u IN fv (ptpm [(u,z)] t1)` by METIS_TAC [aeq_fv] THEN
-            FULL_SIMP_TAC (srw_ss()) [ptpm_fv, perm_IN, swapstr_def]) THEN
-    FULL_SIMP_TAC (srw_ss()) [aeq_ptpm_eqn] THEN
-    Q.PAT_ASSUM `aeq X Y` MP_TAC THEN
-    ONCE_REWRITE_TAC [GSYM ptpm_sing_to_back] THEN
-    SRW_TAC [][swapstr_def] THEN
-    MATCH_MP_TAC aeq_trans THEN
-    Q.EXISTS_TAC `ptpm [(u,v)] (ptpm [(u,z)] t2)`  THEN
-    FULL_SIMP_TAC (srw_ss()) [ptpm_flip_args, aeq_ptpm_eqn, fresh_swap],
-
-    SRW_TAC [][] THEN MATCH_MP_TAC alt_aeq_lam THEN SRW_TAC [][aeq_ptpm_eqn],
-
-    SRW_TAC [][] THEN MATCH_MP_TAC alt_aeq_lam THEN
-    SRW_TAC [][aeq_ptpm_eqn] THEN
-    `~(z IN fv t2)` by METIS_TAC [SUBSET_DEF, fv_SUBSET_allatoms] THEN
-    ONCE_REWRITE_TAC [GSYM ptpm_sing_to_back] THEN
-    SRW_TAC [][swapstr_def, ptpm_flip_args] THEN
-    MATCH_MP_TAC aeq_trans THEN Q.EXISTS_TAC `ptpm [(u,v)] t2` THEN
-    SRW_TAC [][aeq_ptpm_eqn, fresh_swap]
-  ]);
-
-val lami_nfixed = store_thm(
-  "lami_nfixed",
-  ``aeq (lami n v M1 N1) (lami m u M2 N2) ==> (n = m)``,
-  SRW_TAC [][Once aeq_cases]);
-
-val lami_aeq_thm = store_thm(

@@ Diff output truncated at 100000 characters. @@

This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 9188
          http://hol.svn.sourceforge.net/hol/?rev=9188&view=rev
Author:   michaeln
Date:     2011-08-04 04:55:20 +0000 (Thu, 04 Aug 2011)

Log Message:
-----------
Make ring example a script file that builds as a selftest.

This should make future regressions harder.

Modified Paths:
--------------
    HOL/tools/build-sequence

Added Paths:
-----------
    HOL/examples/rings/
    HOL/examples/rings/ringExamplesScript.sml

Removed Paths:
-------------
    HOL/examples/ring.sml

Deleted: HOL/examples/ring.sml
===================================================================
--- HOL/examples/ring.sml	2011-08-04 04:48:55 UTC (rev 9187)
+++ HOL/examples/ring.sml	2011-08-04 04:55:20 UTC (rev 9188)
@@ -1,98 +0,0 @@
-(*---------------------------------------------------------------------------
-    Normalizers and equality provers for rings. These are applications
-    of general support available in ringLib for normalizing ring terms,
-    and proving equality of ring terms. The library ringLib is Coq
-    technology transported to HOL by Bruno Barras.
-
-   First, we try some examples on natural numbers
- ---------------------------------------------------------------------------*)
-
-load "numRingLib"; open numRingLib;
-
-val num_norm_conv = NUM_NORM_CONV o Parse.Term
-val num_ring_conv = NUM_RING_CONV o Parse.Term;
-
-num_norm_conv ` 3*(9+7) : num `;             (* normalization *)
-num_norm_conv `x+y+x : num`;
-num_norm_conv `(a+b)*(a+b) : num`;
-num_norm_conv `(b+a)*(b+a) : num`;
-num_norm_conv `(a+b)*(a+b)*(a+b) : num`;
-
-num_ring_conv `(a+b)*(a+b) = (b+a)*(b+a) : num`;  (* equality *)
-
-(*---------------------------------------------------------------------------
-      An example: sum of squares
- ---------------------------------------------------------------------------*)
-
-open arithmeticTheory;
-
-val sum_def =
- Define `(sum f 0 = 0n) /\ (sum f (SUC n) = sum f n + f (SUC n))`;
-
-val lemma = Q.prove
-(`!n:num. sum (\m. m * m) n * 6 = n * (n+1) * (2 * n + 1)`,
- Induct
-   THEN RW_TAC std_ss [sum_def,RIGHT_ADD_DISTRIB]
-   THEN NUM_RING_TAC);
-
-val sum_squares = Q.prove
-(`!n:num. sum (\m. m * m) n  = (n*(n+1) * (2*n + 1)) DIV 6`,
- GEN_TAC
-   THEN MATCH_MP_TAC (GSYM DIV_UNIQUE)
-   THEN Q.EXISTS_TAC `0`
-   THEN RW_TAC arith_ss [lemma]);
-
-
-(*---------------------------------------------------------------------------
-       Now the integers
- ---------------------------------------------------------------------------*)
-
-load "integerRingLib"; open integerRingLib;
-
-val int_norm_conv = INT_NORM_CONV o Parse.Term
-val int_ring_conv = INT_RING_CONV o Parse.Term;
-
-int_norm_conv `~(3 * (9 - 7)) : int`;        (* normalization *)
-int_norm_conv `x+y+x:int`;
-int_norm_conv `(a+b)*(a+b) : int`;
-int_norm_conv `(b+a)*(b+a) : int`;
-int_norm_conv `(a+b)*(a+b)*(a+b) : int`;
-int_norm_conv `(a-b)*(a+b) : int`;
-
-int_ring_conv `(a+b)*(a+b) = (b+a)*(b+a) :int`;   (* equality *)
-
-
-(*---------------------------------------------------------------------------
-       Bigger test: 8 squares
- ---------------------------------------------------------------------------*)
-
-Count.apply int_ring_conv
-   `(p1*p1+q1*q1+r1*r1+s1*s1+t1*t1+u1*u1+v1*v1+w1*w1)
-  * (p2*p2+q2*q2+r2*r2+s2*s2+t2*t2+u2*u2+v2*v2+w2*w2)
-
-         =
-
-    (p1*p2-q1*q2-r1*r2-s1*s2-t1*t2-u1*u2-v1*v2-w1*w2)*
-    (p1*p2-q1*q2-r1*r2-s1*s2-t1*t2-u1*u2-v1*v2-w1*w2)
-    +
-    (p1*q2+q1*p2+r1*s2-s1*r2+t1*u2-u1*t2-v1*w2+w1*v2)*
-    (p1*q2+q1*p2+r1*s2-s1*r2+t1*u2-u1*t2-v1*w2+w1*v2)
-    +
-    (p1*r2-q1*s2+r1*p2+s1*q2+t1*v2+u1*w2-v1*t2-w1*u2)*
-    (p1*r2-q1*s2+r1*p2+s1*q2+t1*v2+u1*w2-v1*t2-w1*u2)
-    +
-    (p1*s2+q1*r2-r1*q2+s1*p2+t1*w2-u1*v2+v1*u2-w1*t2)*
-    (p1*s2+q1*r2-r1*q2+s1*p2+t1*w2-u1*v2+v1*u2-w1*t2)
-    +
-    (p1*t2-q1*u2-r1*v2-s1*w2+t1*p2+u1*q2+v1*r2+w1*s2)*
-    (p1*t2-q1*u2-r1*v2-s1*w2+t1*p2+u1*q2+v1*r2+w1*s2)
-    +
-    (p1*u2+q1*t2-r1*w2+s1*v2-t1*q2+u1*p2-v1*s2+w1*r2)*
-    (p1*u2+q1*t2-r1*w2+s1*v2-t1*q2+u1*p2-v1*s2+w1*r2)
-    +
-    (p1*v2+q1*w2+r1*t2-s1*u2-t1*r2+u1*s2+v1*p2-w1*q2)*
-    (p1*v2+q1*w2+r1*t2-s1*u2-t1*r2+u1*s2+v1*p2-w1*q2)
-    +
-    (p1*w2-q1*v2+r1*u2+s1*t2-t1*s2-u1*r2+v1*q2+w1*p2)*
-    (p1*w2-q1*v2+r1*u2+s1*t2-t1*s2-u1*r2+v1*q2+w1*p2)
-    : int`;

Copied: HOL/examples/rings/ringExamplesScript.sml (from rev 9187, HOL/examples/ring.sml)
===================================================================
--- HOL/examples/rings/ringExamplesScript.sml	                        (rev 0)
+++ HOL/examples/rings/ringExamplesScript.sml	2011-08-04 04:55:20 UTC (rev 9188)
@@ -0,0 +1,111 @@
+(*---------------------------------------------------------------------------
+    Normalizers and equality provers for rings. These are applications
+    of general support available in ringLib for normalizing ring terms,
+    and proving equality of ring terms. The library ringLib is Coq
+    technology transported to HOL by Bruno Barras.
+
+   First, we try some examples on natural numbers
+ ---------------------------------------------------------------------------*)
+
+open HolKernel Parse boolLib bossLib
+open numRingLib;
+
+val _ = new_theory "ringExamples"
+
+val num_norm_conv = NUM_NORM_CONV o Parse.Term
+val num_ring_conv = NUM_RING_CONV o Parse.Term;
+
+val res1 = num_norm_conv ` 3*(9+7) : num `;             (* normalization *)
+val res2 = num_norm_conv `x+y+x : num`;
+val res3 = num_norm_conv `(a+b)*(a+b) : num`;
+val res4 = num_norm_conv `(b+a)*(b+a) : num`;
+val res5 = num_norm_conv `(a+b)*(a+b)*(a+b) : num`;
+
+val res6 = num_ring_conv `(a+b)*(a+b) = (b+a)*(b+a) : num`;  (* equality *)
+val _ = if rhs (concl res6) <> boolSyntax.T then raise Fail "res6 test failed"
+        else ()
+
+(*---------------------------------------------------------------------------
+      An example: sum of squares
+ ---------------------------------------------------------------------------*)
+
+open arithmeticTheory;
+
+val sum_def =
+ Define `(sum f 0 = 0n) /\ (sum f (SUC n) = sum f n + f (SUC n))`;
+
+val lemma = Q.prove
+(`!n:num. sum (\m. m * m) n * 6 = n * (n+1) * (2 * n + 1)`,
+ Induct
+   THEN RW_TAC std_ss [sum_def,RIGHT_ADD_DISTRIB]
+   THEN NUM_RING_TAC);
+
+val sum_squares = Q.prove
+(`!n:num. sum (\m. m * m) n  = (n*(n+1) * (2*n + 1)) DIV 6`,
+ GEN_TAC
+   THEN MATCH_MP_TAC (GSYM DIV_UNIQUE)
+   THEN Q.EXISTS_TAC `0`
+   THEN RW_TAC arith_ss [lemma]);
+
+
+(*---------------------------------------------------------------------------
+       Now the integers
+ ---------------------------------------------------------------------------*)
+
+open integerRingLib;
+
+val int_norm_conv = INT_NORM_CONV o Parse.Term
+val int_ring_conv = INT_RING_CONV o Parse.Term;
+
+val _ = int_norm_conv `~(3 * (9 - 7)) : int`;        (* normalization *)
+val _ = int_norm_conv `x+y+x:int`;
+val _ = int_norm_conv `(a+b)*(a+b) : int`;
+val _ = int_norm_conv `(b+a)*(b+a) : int`;
+val _ = int_norm_conv `(a+b)*(a+b)*(a+b) : int`;
+val _ = int_norm_conv `(a-b)*(a+b) : int`;
+
+val res7 = int_ring_conv `(a+b)*(a+b) = (b+a)*(b+a) :int`;   (* equality *)
+val _ = if rhs (concl res7) <> boolSyntax.T then raise Fail "res7 test failed"
+        else ()
+
+
+(*---------------------------------------------------------------------------
+       Bigger test: 8 squares
+ ---------------------------------------------------------------------------*)
+
+val _ = Q.store_thm(
+  "big_int_ring_example",
+   `(p1*p1+q1*q1+r1*r1+s1*s1+t1*t1+u1*u1+v1*v1+w1*w1)
+  * (p2*p2+q2*q2+r2*r2+s2*s2+t2*t2+u2*u2+v2*v2+w2*w2)
+
+         =
+
+    (p1*p2-q1*q2-r1*r2-s1*s2-t1*t2-u1*u2-v1*v2-w1*w2)*
+    (p1*p2-q1*q2-r1*r2-s1*s2-t1*t2-u1*u2-v1*v2-w1*w2)
+    +
+    (p1*q2+q1*p2+r1*s2-s1*r2+t1*u2-u1*t2-v1*w2+w1*v2)*
+    (p1*q2+q1*p2+r1*s2-s1*r2+t1*u2-u1*t2-v1*w2+w1*v2)
+    +
+    (p1*r2-q1*s2+r1*p2+s1*q2+t1*v2+u1*w2-v1*t2-w1*u2)*
+    (p1*r2-q1*s2+r1*p2+s1*q2+t1*v2+u1*w2-v1*t2-w1*u2)
+    +
+    (p1*s2+q1*r2-r1*q2+s1*p2+t1*w2-u1*v2+v1*u2-w1*t2)*
+    (p1*s2+q1*r2-r1*q2+s1*p2+t1*w2-u1*v2+v1*u2-w1*t2)
+    +
+    (p1*t2-q1*u2-r1*v2-s1*w2+t1*p2+u1*q2+v1*r2+w1*s2)*
+    (p1*t2-q1*u2-r1*v2-s1*w2+t1*p2+u1*q2+v1*r2+w1*s2)
+    +
+    (p1*u2+q1*t2-r1*w2+s1*v2-t1*q2+u1*p2-v1*s2+w1*r2)*
+    (p1*u2+q1*t2-r1*w2+s1*v2-t1*q2+u1*p2-v1*s2+w1*r2)
+    +
+    (p1*v2+q1*w2+r1*t2-s1*u2-t1*r2+u1*s2+v1*p2-w1*q2)*
+    (p1*v2+q1*w2+r1*t2-s1*u2-t1*r2+u1*s2+v1*p2-w1*q2)
+    +
+    (p1*w2-q1*v2+r1*u2+s1*t2-t1*s2-u1*r2+v1*q2+w1*p2)*
+    (p1*w2-q1*v2+r1*u2+s1*t2-t1*s2-u1*r2+v1*q2+w1*p2)
+    : int`,
+  CONV_TAC (Count.apply INT_RING_CONV))
+
+val _ = export_theory()
+
+


Property changes on: HOL/examples/rings/ringExamplesScript.sml
___________________________________________________________________
Added: svn:mime-type
   + text/plain
Added: svn:keywords
   + Author Date Id Revision
Added: svn:eol-style
   + native

Modified: HOL/tools/build-sequence
===================================================================
--- HOL/tools/build-sequence	2011-08-04 04:48:55 UTC (rev 9187)
+++ HOL/tools/build-sequence	2011-08-04 04:55:20 UTC (rev 9188)
@@ -108,6 +108,7 @@
 !examples/ARM/arm6-verification
 !!examples/ARM/arm6-verification/correctness
 src/ring/src
+!examples/rings
 src/integer
 src/llist
 src/path


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.

Revision: 9202
          http://hol.svn.sourceforge.net/hol/?rev=9202&view=rev
Author:   xrchz
Date:     2011-08-07 12:09:59 +0000 (Sun, 07 Aug 2011)

Log Message:
-----------
Add category theory example to release notes.

Modified Paths:
--------------
    HOL/doc/kananaskis-7.release.html
    HOL/tools/build-sequence

Modified: HOL/doc/kananaskis-7.release.html
===================================================================
--- HOL/doc/kananaskis-7.release.html	2011-08-05 06:45:10 UTC (rev 9201)
+++ HOL/doc/kananaskis-7.release.html	2011-08-07 12:09:59 UTC (rev 9202)
@@ -194,6 +194,8 @@
 <ul>
 <li> <p> A mechanisation of first-order and nominal unification done in an accumulator-passing style with <q>triangular</q> substitutions.
 In <code>examples/unification/triangular</code>.
+<li><p> Some basic category theory (up to the Yoneda lemma), including two categories of <q>sets</q>: one using HOL sets (predicates) and one using the axiomatically introduced type from <code>zfsetTheory</code>.
+In <code>examples/category</code>.
 </ul>
 
 <h2 id="incompatibilities">Incompatibilities:</h2>

Modified: HOL/tools/build-sequence
===================================================================
--- HOL/tools/build-sequence	2011-08-05 06:45:10 UTC (rev 9201)
+++ HOL/tools/build-sequence	2011-08-07 12:09:59 UTC (rev 9202)
@@ -152,6 +152,7 @@
 #
 !examples/MLsyntax
 !examples/zfset
+!!examples/category
 !!examples/miller/ho_prover
 !!examples/miller/miller
 !examples/ordinal


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.