src/HOL/Import/shuffler.ML
author skalberg
Sun, 13 Feb 2005 17:15:14 +0100
changeset 15531 08c8dad8e399
parent 14854 61bdf2ae4dc5
child 15570 8d8c70b41bab
permissions -rw-r--r--
Deleted Library.option type.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
14620
1be590fd2422 Minor cleanup of headers and some speedup of the HOL4 import.
skalberg
parents: 14518
diff changeset
     1
(*  Title:      HOL/Import/shuffler.ML
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
     2
    ID:         $Id$
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
     3
    Author:     Sebastian Skalberg, TU Muenchen
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
     4
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
     5
Package for proving two terms equal by normalizing (hence the
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
     6
"shuffler" name).  Uses the simplifier for the normalization.
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
     7
*)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
     8
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
     9
signature Shuffler =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    10
sig
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    11
    val debug      : bool ref
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    12
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    13
    val norm_term  : theory -> term -> thm
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    14
    val make_equal : theory -> term -> term -> thm option
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    15
    val set_prop   : theory -> term -> (string * thm) list -> (string * thm) option
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    16
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    17
    val find_potential: theory -> term -> (string * thm) list
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    18
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    19
    val gen_shuffle_tac: theory -> bool -> (string * thm) list -> int -> tactic
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    20
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    21
    val shuffle_tac: (string * thm) list -> int -> tactic
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    22
    val search_tac : (string * thm) list -> int -> tactic
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    23
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    24
    val print_shuffles: theory -> unit
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    25
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    26
    val add_shuffle_rule: thm -> theory -> theory
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    27
    val shuffle_attr: theory attribute
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    28
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    29
    val setup      : (theory -> theory) list
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    30
end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    31
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    32
structure Shuffler :> Shuffler =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    33
struct
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    34
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    35
val debug = ref false
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    36
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    37
fun if_debug f x = if !debug then f x else ()
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    38
val message = if_debug writeln
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    39
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    40
(*Prints exceptions readably to users*)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    41
fun print_sign_exn_unit sign e = 
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    42
  case e of
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    43
     THM (msg,i,thms) =>
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    44
	 (writeln ("Exception THM " ^ string_of_int i ^ " raised:\n" ^ msg);
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    45
	  seq print_thm thms)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    46
   | THEORY (msg,thys) =>
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    47
	 (writeln ("Exception THEORY raised:\n" ^ msg);
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    48
	  seq (Pretty.writeln o Display.pretty_theory) thys)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    49
   | TERM (msg,ts) =>
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    50
	 (writeln ("Exception TERM raised:\n" ^ msg);
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    51
	  seq (writeln o Sign.string_of_term sign) ts)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    52
   | TYPE (msg,Ts,ts) =>
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    53
	 (writeln ("Exception TYPE raised:\n" ^ msg);
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    54
	  seq (writeln o Sign.string_of_typ sign) Ts;
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    55
	  seq (writeln o Sign.string_of_term sign) ts)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    56
   | e => raise e
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    57
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    58
(*Prints an exception, then fails*)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    59
fun print_sign_exn sign e = (print_sign_exn_unit sign e; raise e)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    60
14848
83f1dc18f1f1 oops -- no Output.out here;
wenzelm
parents: 14818
diff changeset
    61
val string_of_thm = Library.setmp print_mode [] string_of_thm;
83f1dc18f1f1 oops -- no Output.out here;
wenzelm
parents: 14818
diff changeset
    62
val string_of_cterm = Library.setmp print_mode [] string_of_cterm;
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    63
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    64
fun mk_meta_eq th =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    65
    (case concl_of th of
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    66
	 Const("Trueprop",_) $ (Const("op =",_) $ _ $ _) => th RS eq_reflection
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    67
       | Const("==",_) $ _ $ _ => th
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    68
       | _ => raise THM("Not an equality",0,[th]))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    69
    handle _ => raise THM("Couldn't make meta equality",0,[th])
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    70
				   
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    71
fun mk_obj_eq th =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    72
    (case concl_of th of
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    73
	 Const("Trueprop",_) $ (Const("op =",_) $ _ $ _) => th
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    74
       | Const("==",_) $ _ $ _ => th RS meta_eq_to_obj_eq
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    75
       | _ => raise THM("Not an equality",0,[th]))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    76
    handle _ => raise THM("Couldn't make object equality",0,[th])
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    77
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    78
structure ShuffleDataArgs: THEORY_DATA_ARGS =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    79
struct
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    80
val name = "HOL/shuffles"
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    81
type T = thm list
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    82
val empty = []
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    83
val copy = I
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    84
val prep_ext = I
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    85
val merge = Library.gen_union Thm.eq_thm
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    86
fun print sg thms =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    87
    Pretty.writeln (Pretty.big_list "Shuffle theorems:"
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    88
				    (map Display.pretty_thm thms))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    89
end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    90
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    91
structure ShuffleData = TheoryDataFun(ShuffleDataArgs)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    92
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    93
val weaken =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    94
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    95
	val cert = cterm_of (sign_of ProtoPure.thy)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    96
	val P = Free("P",propT)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    97
	val Q = Free("Q",propT)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    98
	val PQ = Logic.mk_implies(P,Q)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
    99
	val PPQ = Logic.mk_implies(P,PQ)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   100
	val cP = cert P
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   101
	val cQ = cert Q
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   102
	val cPQ = cert PQ
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   103
	val cPPQ = cert PPQ
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   104
	val th1 = assume cPQ |> implies_intr_list [cPQ,cP]
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   105
	val th3 = assume cP
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   106
	val th4 = implies_elim_list (assume cPPQ) [th3,th3]
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   107
				    |> implies_intr_list [cPPQ,cP]
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   108
    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   109
	equal_intr th4 th1 |> standard
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   110
    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   111
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   112
val imp_comm =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   113
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   114
	val cert = cterm_of (sign_of ProtoPure.thy)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   115
	val P = Free("P",propT)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   116
	val Q = Free("Q",propT)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   117
	val R = Free("R",propT)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   118
	val PQR = Logic.mk_implies(P,Logic.mk_implies(Q,R))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   119
	val QPR = Logic.mk_implies(Q,Logic.mk_implies(P,R))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   120
	val cP = cert P
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   121
	val cQ = cert Q
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   122
	val cPQR = cert PQR
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   123
	val cQPR = cert QPR
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   124
	val th1 = implies_elim_list (assume cPQR) [assume cP,assume cQ]
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   125
				    |> implies_intr_list [cPQR,cQ,cP]
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   126
	val th2 = implies_elim_list (assume cQPR) [assume cQ,assume cP]
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   127
				    |> implies_intr_list [cQPR,cP,cQ]
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   128
    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   129
	equal_intr th1 th2 |> standard
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   130
    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   131
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   132
val def_norm =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   133
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   134
	val cert = cterm_of (sign_of ProtoPure.thy)
14854
61bdf2ae4dc5 removed obsolete sort 'logic';
wenzelm
parents: 14848
diff changeset
   135
	val aT = TFree("'a",[])
61bdf2ae4dc5 removed obsolete sort 'logic';
wenzelm
parents: 14848
diff changeset
   136
	val bT = TFree("'b",[])
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   137
	val v = Free("v",aT)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   138
	val P = Free("P",aT-->bT)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   139
	val Q = Free("Q",aT-->bT)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   140
	val cvPQ = cert (list_all ([("v",aT)],Logic.mk_equals(P $ Bound 0,Q $ Bound 0)))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   141
	val cPQ = cert (Logic.mk_equals(P,Q))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   142
	val cv = cert v
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   143
	val rew = assume cvPQ
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   144
			 |> forall_elim cv
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   145
			 |> abstract_rule "v" cv
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   146
	val (lhs,rhs) = Logic.dest_equals(concl_of rew)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   147
	val th1 = transitive (transitive
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   148
				  (eta_conversion (cert lhs) |> symmetric)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   149
				  rew)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   150
			     (eta_conversion (cert rhs))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   151
			     |> implies_intr cvPQ
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   152
	val th2 = combination (assume cPQ) (reflexive cv)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   153
			      |> forall_intr cv
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   154
			      |> implies_intr cPQ
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   155
    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   156
	equal_intr th1 th2 |> standard
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   157
    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   158
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   159
val all_comm =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   160
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   161
	val cert = cterm_of (sign_of ProtoPure.thy)
14854
61bdf2ae4dc5 removed obsolete sort 'logic';
wenzelm
parents: 14848
diff changeset
   162
	val xT = TFree("'a",[])
61bdf2ae4dc5 removed obsolete sort 'logic';
wenzelm
parents: 14848
diff changeset
   163
	val yT = TFree("'b",[])
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   164
	val P = Free("P",xT-->yT-->propT)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   165
	val lhs = all xT $ (Abs("x",xT,all yT $ (Abs("y",yT,P $ Bound 1 $ Bound 0))))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   166
	val rhs = all yT $ (Abs("y",yT,all xT $ (Abs("x",xT,P $ Bound 0 $ Bound 1))))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   167
	val cl = cert lhs
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   168
	val cr = cert rhs
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   169
	val cx = cert (Free("x",xT))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   170
	val cy = cert (Free("y",yT))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   171
	val th1 = assume cr
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   172
			 |> forall_elim_list [cy,cx]
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   173
			 |> forall_intr_list [cx,cy]
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   174
			 |> implies_intr cr
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   175
	val th2 = assume cl
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   176
			 |> forall_elim_list [cx,cy]
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   177
			 |> forall_intr_list [cy,cx]
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   178
			 |> implies_intr cl
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   179
    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   180
	equal_intr th1 th2 |> standard
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   181
    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   182
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   183
val equiv_comm =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   184
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   185
	val cert = cterm_of (sign_of ProtoPure.thy)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   186
	val T    = TFree("'a",[])
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   187
	val t    = Free("t",T)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   188
	val u    = Free("u",T)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   189
	val ctu  = cert (Logic.mk_equals(t,u))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   190
	val cut  = cert (Logic.mk_equals(u,t))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   191
	val th1  = assume ctu |> symmetric |> implies_intr ctu
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   192
	val th2  = assume cut |> symmetric |> implies_intr cut
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   193
    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   194
	equal_intr th1 th2 |> standard
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   195
    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   196
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   197
(* This simplification procedure rewrites !!x y. P x y
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   198
deterministicly, in order for the normalization function, defined
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   199
below, to handle nested quantifiers robustly *)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   200
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   201
local
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   202
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   203
exception RESULT of int
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   204
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   205
fun find_bound n (Bound i) = if i = n then raise RESULT 0
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   206
			     else if i = n+1 then raise RESULT 1
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   207
			     else ()
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   208
  | find_bound n (t $ u) = (find_bound n t; find_bound n u)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   209
  | find_bound n (Abs(_,_,t)) = find_bound (n+1) t
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   210
  | find_bound _ _ = ()
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   211
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   212
fun swap_bound n (Bound i) = if i = n then Bound (n+1)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   213
			     else if i = n+1 then Bound n
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   214
			     else Bound i
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   215
  | swap_bound n (t $ u) = (swap_bound n t $ swap_bound n u)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   216
  | swap_bound n (Abs(x,xT,t)) = Abs(x,xT,swap_bound (n+1) t)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   217
  | swap_bound n t = t
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   218
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   219
fun rew_th sg (xv as (x,xT)) (yv as (y,yT)) t =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   220
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   221
	val lhs = list_all ([xv,yv],t)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   222
	val rhs = list_all ([yv,xv],swap_bound 0 t)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   223
	val rew = Logic.mk_equals (lhs,rhs)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   224
	val init = trivial (cterm_of sg rew)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   225
    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   226
	(all_comm RS init handle e => (message "rew_th"; print_exn e))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   227
    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   228
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   229
fun quant_rewrite sg assumes (t as Const("all",T1) $ (Abs(x,xT,Const("all",T2) $ Abs(y,yT,body)))) =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   230
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   231
	val res = (find_bound 0 body;2) handle RESULT i => i
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   232
    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   233
	case res of
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   234
	    0 => SOME (rew_th sg (x,xT) (y,yT) body)
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   235
	  | 1 => if string_ord(y,x) = LESS
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   236
		 then
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   237
		     let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   238
			 val newt = Const("all",T1) $ (Abs(y,xT,Const("all",T2) $ Abs(x,yT,body)))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   239
			 val t_th    = reflexive (cterm_of sg t)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   240
			 val newt_th = reflexive (cterm_of sg newt)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   241
		     in
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   242
			 SOME (transitive t_th newt_th)
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   243
		     end
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   244
		 else NONE
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   245
	  | _ => error "norm_term (quant_rewrite) internal error"
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   246
     end
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   247
  | quant_rewrite _ _ _ = (warning "quant_rewrite: Unknown lhs"; NONE)
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   248
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   249
fun freeze_thaw_term t =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   250
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   251
	val tvars = term_tvars t
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   252
	val tfree_names = add_term_tfree_names(t,[])
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   253
	val (type_inst,_) =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   254
	    foldl (fn ((inst,used),(w as (v,_),S)) =>
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   255
		      let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   256
			  val v' = variant used v
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   257
		      in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   258
			  ((w,TFree(v',S))::inst,v'::used)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   259
		      end)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   260
		  (([],tfree_names),tvars)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   261
	val t' = subst_TVars type_inst t
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   262
    in
14518
c3019a66180f Added a number of explicit type casts and delayed evaluations (all seemingly
skalberg
parents: 14516
diff changeset
   263
	(t',map (fn (w,TFree(v,S)) => (v,TVar(w,S))
c3019a66180f Added a number of explicit type casts and delayed evaluations (all seemingly
skalberg
parents: 14516
diff changeset
   264
		  | _ => error "Internal error in Shuffler.freeze_thaw") type_inst)
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   265
    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   266
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   267
fun inst_tfrees sg [] thm = thm
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   268
  | inst_tfrees sg ((name,U)::rest) thm = 
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   269
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   270
	val cU = ctyp_of sg U
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   271
	val tfree_names = add_term_tfree_names (prop_of thm,[])
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   272
	val (thm',rens) = varifyT' (tfree_names \ name) thm
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   273
	val mid = 
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   274
	    case rens of
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   275
		[] => thm'
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   276
	      | [(_,idx)] => instantiate ([(idx,cU)],[]) thm'
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   277
	      | _ => error "Shuffler.inst_tfrees internal error"
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   278
    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   279
	inst_tfrees sg rest mid
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   280
    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   281
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   282
fun is_Abs (Abs _) = true
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   283
  | is_Abs _ = false
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   284
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   285
fun eta_redex (t $ Bound 0) =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   286
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   287
	fun free n (Bound i) = i = n
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   288
	  | free n (t $ u) = free n t orelse free n u
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   289
	  | free n (Abs(_,_,t)) = free (n+1) t
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   290
	  | free n _ = false
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   291
    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   292
	not (free 0 t)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   293
    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   294
  | eta_redex _ = false
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   295
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   296
fun eta_contract sg assumes origt =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   297
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   298
	val (typet,Tinst) = freeze_thaw_term origt
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   299
	val (init,thaw) = freeze_thaw (reflexive (cterm_of sg typet))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   300
	val final = inst_tfrees sg Tinst o thaw
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   301
	val t = #1 (Logic.dest_equals (prop_of init))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   302
	val _ =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   303
	    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   304
		val lhs = #1 (Logic.dest_equals (prop_of (final init)))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   305
	    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   306
		if not (lhs aconv origt)
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   307
		then (writeln "SOMEthing is utterly wrong: (orig,lhs,frozen type,t,tinst)";
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   308
		      writeln (string_of_cterm (cterm_of sg origt));
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   309
		      writeln (string_of_cterm (cterm_of sg lhs));
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   310
		      writeln (string_of_cterm (cterm_of sg typet));
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   311
		      writeln (string_of_cterm (cterm_of sg t));
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   312
		      app (fn (n,T) => writeln (n ^ ": " ^ (string_of_ctyp (ctyp_of sg T)))) Tinst;
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   313
		      writeln "done")
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   314
		else ()
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   315
	    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   316
    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   317
	case t of
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   318
	    Const("all",_) $ (Abs(x,xT,Const("==",eqT) $ P $ Q)) =>
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   319
	    ((if eta_redex P andalso eta_redex Q
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   320
	      then
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   321
		  let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   322
		      val cert = cterm_of sg
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   323
		      val v = Free(variant (add_term_free_names(t,[])) "v",xT)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   324
		      val cv = cert v
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   325
		      val ct = cert t
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   326
		      val th = (assume ct)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   327
				   |> forall_elim cv
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   328
				   |> abstract_rule x cv
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   329
		      val ext_th = eta_conversion (cert (Abs(x,xT,P)))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   330
		      val th' = transitive (symmetric ext_th) th
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   331
		      val cu = cert (prop_of th')
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   332
		      val uth = combination (assume cu) (reflexive cv)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   333
		      val uth' = (beta_conversion false (cert (Abs(x,xT,Q) $ v)))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   334
				     |> transitive uth
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   335
				     |> forall_intr cv
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   336
				     |> implies_intr cu
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   337
		      val rew_th = equal_intr (th' |> implies_intr ct) uth'
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   338
		      val res = final rew_th
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   339
		      val lhs = (#1 (Logic.dest_equals (prop_of res)))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   340
		  in
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   341
		       SOME res
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   342
		  end
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   343
	      else NONE)
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   344
	     handle e => (writeln "eta_contract:";print_exn e))
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   345
	  | _ => (error ("Bad eta_contract argument" ^ (string_of_cterm (cterm_of sg t))); NONE)
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   346
    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   347
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   348
fun beta_fun sg assume t =
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   349
    SOME (beta_conversion true (cterm_of sg t))
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   350
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   351
fun eta_expand sg assumes origt =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   352
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   353
	val (typet,Tinst) = freeze_thaw_term origt
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   354
	val (init,thaw) = freeze_thaw (reflexive (cterm_of sg typet))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   355
	val final = inst_tfrees sg Tinst o thaw
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   356
	val t = #1 (Logic.dest_equals (prop_of init))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   357
	val _ =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   358
	    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   359
		val lhs = #1 (Logic.dest_equals (prop_of (final init)))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   360
	    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   361
		if not (lhs aconv origt)
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   362
		then (writeln "SOMEthing is utterly wrong: (orig,lhs,frozen type,t,tinst)";
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   363
		      writeln (string_of_cterm (cterm_of sg origt));
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   364
		      writeln (string_of_cterm (cterm_of sg lhs));
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   365
		      writeln (string_of_cterm (cterm_of sg typet));
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   366
		      writeln (string_of_cterm (cterm_of sg t));
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   367
		      app (fn (n,T) => writeln (n ^ ": " ^ (string_of_ctyp (ctyp_of sg T)))) Tinst;
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   368
		      writeln "done")
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   369
		else ()
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   370
	    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   371
    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   372
	case t of
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   373
	    Const("==",T) $ P $ Q =>
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   374
	    if is_Abs P orelse is_Abs Q
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   375
	    then (case domain_type T of
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   376
		      Type("fun",[aT,bT]) =>
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   377
		      let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   378
			  val cert = cterm_of sg
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   379
			  val vname = variant (add_term_free_names(t,[])) "v"
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   380
			  val v = Free(vname,aT)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   381
			  val cv = cert v
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   382
			  val ct = cert t
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   383
			  val th1 = (combination (assume ct) (reflexive cv))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   384
					|> forall_intr cv
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   385
					|> implies_intr ct
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   386
			  val concl = cert (concl_of th1)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   387
			  val th2 = (assume concl)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   388
					|> forall_elim cv
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   389
					|> abstract_rule vname cv
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   390
			  val (lhs,rhs) = Logic.dest_equals (prop_of th2)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   391
			  val elhs = eta_conversion (cert lhs)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   392
			  val erhs = eta_conversion (cert rhs)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   393
			  val th2' = transitive
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   394
					 (transitive (symmetric elhs) th2)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   395
					 erhs
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   396
			  val res = equal_intr th1 (th2' |> implies_intr concl)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   397
			  val res' = final res
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   398
		      in
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   399
			  SOME res'
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   400
		      end
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   401
		    | _ => NONE)
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   402
	    else NONE
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   403
	  | _ => (error ("Bad eta_expand argument" ^ (string_of_cterm (cterm_of sg t))); NONE)
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   404
    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   405
    handle e => (writeln "eta_expand internal error";print_exn e)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   406
14854
61bdf2ae4dc5 removed obsolete sort 'logic';
wenzelm
parents: 14848
diff changeset
   407
fun mk_tfree s = TFree("'"^s,[])
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   408
val xT = mk_tfree "a"
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   409
val yT = mk_tfree "b"
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   410
val P  = Var(("P",0),xT-->yT-->propT)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   411
val Q  = Var(("Q",0),xT-->yT)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   412
val R  = Var(("R",0),xT-->yT)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   413
val S  = Var(("S",0),xT)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   414
in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   415
fun beta_simproc sg = Simplifier.simproc_i
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   416
		      sg
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   417
		      "Beta-contraction"
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   418
		      [Abs("x",xT,Q) $ S]
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   419
		      beta_fun
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   420
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   421
fun quant_simproc sg = Simplifier.simproc_i
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   422
			   sg
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   423
			   "Ordered rewriting of nested quantifiers"
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   424
			   [all xT $ (Abs("x",xT,all yT $ (Abs("y",yT,P $ Bound 1 $ Bound 0))))]
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   425
			   quant_rewrite
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   426
fun eta_expand_simproc sg = Simplifier.simproc_i
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   427
			 sg
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   428
			 "Smart eta-expansion by equivalences"
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   429
			 [Logic.mk_equals(Q,R)]
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   430
			 eta_expand
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   431
fun eta_contract_simproc sg = Simplifier.simproc_i
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   432
			 sg
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   433
			 "Smart handling of eta-contractions"
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   434
			 [all xT $ (Abs("x",xT,Logic.mk_equals(Q $ Bound 0,R $ Bound 0)))]
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   435
			 eta_contract
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   436
end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   437
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   438
(* Disambiguates the names of bound variables in a term, returning t
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   439
== t' where all the names of bound variables in t' are unique *)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   440
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   441
fun disamb_bound sg t =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   442
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   443
	
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   444
	fun F (t $ u,idx) =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   445
	    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   446
		val (t',idx') = F (t,idx)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   447
		val (u',idx'') = F (u,idx')
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   448
	    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   449
		(t' $ u',idx'')
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   450
	    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   451
	  | F (Abs(x,xT,t),idx) =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   452
	    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   453
		val x' = "x" ^ (LargeInt.toString idx) (* amazing *)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   454
		val (t',idx') = F (t,idx+1)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   455
	    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   456
		(Abs(x',xT,t'),idx')
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   457
	    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   458
	  | F arg = arg
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   459
	val (t',_) = F (t,0)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   460
	val ct = cterm_of sg t
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   461
	val ct' = cterm_of sg t'
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   462
	val res = transitive (reflexive ct) (reflexive ct')
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   463
	val _ = message ("disamb_term: " ^ (string_of_thm res))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   464
    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   465
	res
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   466
    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   467
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   468
(* Transforms a term t to some normal form t', returning the theorem t
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   469
== t'.  This is originally a help function for make_equal, but might
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   470
be handy in its own right, for example for indexing terms. *)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   471
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   472
fun norm_term thy t =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   473
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   474
	val sg = sign_of thy
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   475
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   476
	val norms = ShuffleData.get thy
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   477
	val ss = empty_ss setmksimps single
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   478
			  addsimps (map (transfer_sg sg) norms)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   479
	fun chain f th =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   480
	    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   481
		val rhs = snd (dest_equals (cprop_of th))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   482
	    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   483
		transitive th (f rhs)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   484
	    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   485
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   486
	val th =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   487
	    t |> disamb_bound sg
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   488
	      |> chain (Simplifier.full_rewrite
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   489
			    (ss addsimprocs [quant_simproc sg,eta_expand_simproc sg,eta_contract_simproc sg]))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   490
	      |> chain eta_conversion
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   491
	      |> strip_shyps
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   492
	val _ = message ("norm_term: " ^ (string_of_thm th))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   493
    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   494
	th
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   495
    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   496
    handle e => (writeln "norm_term internal error"; print_sign_exn (sign_of thy) e)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   497
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   498
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   499
(* Closes a theorem with respect to free and schematic variables (does
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   500
not touch type variables, though). *)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   501
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   502
fun close_thm th =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   503
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   504
	val sg = sign_of_thm th
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   505
	val c = prop_of th
14854
61bdf2ae4dc5 removed obsolete sort 'logic';
wenzelm
parents: 14848
diff changeset
   506
	val vars = add_term_frees (c,add_term_vars(c,[]))
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   507
    in
14854
61bdf2ae4dc5 removed obsolete sort 'logic';
wenzelm
parents: 14848
diff changeset
   508
	Drule.forall_intr_list (map (cterm_of sg) vars) th
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   509
    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   510
    handle e => (writeln "close_thm internal error"; print_exn e)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   511
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   512
(* Normalizes a theorem's conclusion using norm_term. *)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   513
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   514
fun norm_thm thy th =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   515
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   516
	val c = prop_of th
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   517
    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   518
	equal_elim (norm_term thy c) th
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   519
    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   520
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   521
(* make_equal sg t u tries to construct the theorem t == u under the
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   522
signature sg.  If it succeeds, SOME (t == u) is returned, otherwise
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   523
NONE is returned. *)
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   524
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   525
fun make_equal sg t u =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   526
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   527
	val t_is_t' = norm_term sg t
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   528
	val u_is_u' = norm_term sg u
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   529
	val th = transitive t_is_t' (symmetric u_is_u')
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   530
	val _ = message ("make_equal: SOME " ^ (string_of_thm th))
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   531
    in
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   532
	SOME th
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   533
    end
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   534
    handle e as THM _ => (message "make_equal: NONE";NONE)
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   535
			 
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   536
fun match_consts ignore t (* th *) =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   537
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   538
	fun add_consts (Const (c, _), cs) =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   539
	    if c mem_string ignore
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   540
	    then cs
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   541
	    else c ins_string cs
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   542
	  | add_consts (t $ u, cs) = add_consts (t, add_consts (u, cs))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   543
	  | add_consts (Abs (_, _, t), cs) = add_consts (t, cs)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   544
	  | add_consts (_, cs) = cs
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   545
	val t_consts = add_consts(t,[])
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   546
    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   547
     fn (name,th) =>
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   548
	let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   549
	    val th_consts = add_consts(prop_of th,[])
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   550
	in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   551
	    eq_set(t_consts,th_consts)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   552
	end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   553
    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   554
    
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   555
val collect_ignored =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   556
    foldr (fn (thm,cs) =>
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   557
	      let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   558
		  val (lhs,rhs) = Logic.dest_equals (prop_of thm)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   559
		  val ignore_lhs = term_consts lhs \\ term_consts rhs
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   560
		  val ignore_rhs = term_consts rhs \\ term_consts lhs
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   561
	      in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   562
		  foldr (op ins_string) (ignore_lhs @ ignore_rhs,cs)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   563
	      end)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   564
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   565
(* set_prop t thms tries to make a theorem with the proposition t from
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   566
one of the theorems thms, by shuffling the propositions around.  If it
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   567
succeeds, SOME theorem is returned, otherwise NONE.  *)
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   568
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   569
fun set_prop thy t =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   570
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   571
	val sg = sign_of thy
14854
61bdf2ae4dc5 removed obsolete sort 'logic';
wenzelm
parents: 14848
diff changeset
   572
	val vars = add_term_frees (t,add_term_vars (t,[]))
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   573
	val closed_t = foldr (fn (v,body) => let val vT = type_of v
14854
61bdf2ae4dc5 removed obsolete sort 'logic';
wenzelm
parents: 14848
diff changeset
   574
					     in all vT $ (Abs("x",vT,abstract_over(v,body))) end) (vars,t)
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   575
	val rew_th = norm_term thy closed_t
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   576
	val rhs = snd (dest_equals (cprop_of rew_th))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   577
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   578
	val shuffles = ShuffleData.get thy
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   579
	fun process [] = NONE
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   580
	  | process ((name,th)::thms) =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   581
	    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   582
		val norm_th = varifyT (norm_thm thy (close_thm (transfer_sg sg th)))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   583
		val triv_th = trivial rhs
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   584
		val _ = message ("Shuffler.set_prop: Gluing together " ^ (string_of_thm norm_th) ^ " and " ^ (string_of_thm triv_th))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   585
		val mod_th = case Seq.pull (bicompose true (false,norm_th,0) 1 triv_th) of
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   586
				 SOME(th,_) => SOME th
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   587
			       | NONE => NONE
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   588
	    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   589
		case mod_th of
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   590
		    SOME mod_th =>
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   591
		    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   592
			val closed_th = equal_elim (symmetric rew_th) mod_th
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   593
		    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   594
			message ("Shuffler.set_prop succeeded by " ^ name);
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   595
			SOME (name,forall_elim_list (map (cterm_of sg) vars) closed_th)
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   596
		    end
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   597
		  | NONE => process thms
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   598
	    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   599
	    handle e as THM _ => process thms
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   600
    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   601
	fn thms =>
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   602
	   case process thms of
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   603
	       res as SOME (name,th) => if (prop_of th) aconv t
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   604
					then res
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   605
					else error "Internal error in set_prop"
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   606
	     | NONE => NONE
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   607
    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   608
    handle e => (writeln "set_prop internal error"; print_exn e)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   609
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   610
fun find_potential thy t =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   611
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   612
	val shuffles = ShuffleData.get thy
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   613
	val ignored = collect_ignored(shuffles,[])
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   614
	val rel_consts = term_consts t \\ ignored
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   615
	val pot_thms = PureThy.thms_containing_consts thy rel_consts
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   616
    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   617
	filter (match_consts ignored t) pot_thms
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   618
    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   619
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   620
fun gen_shuffle_tac thy search thms i st =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   621
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   622
	val _ = message ("Shuffling " ^ (string_of_thm st))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   623
	val t = nth_elem(i-1,prems_of st)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   624
	val set = set_prop thy t
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   625
	fun process_tac thms st =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   626
	    case set thms of
15531
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   627
		SOME (_,th) => Seq.of_list (compose (th,i,st))
08c8dad8e399 Deleted Library.option type.
skalberg
parents: 14854
diff changeset
   628
	      | NONE => Seq.empty
14516
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   629
    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   630
	(process_tac thms APPEND (if search
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   631
				  then process_tac (find_potential thy t)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   632
				  else no_tac)) st
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   633
    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   634
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   635
fun shuffle_tac thms i st =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   636
    gen_shuffle_tac (the_context()) false thms i st
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   637
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   638
fun search_tac thms i st =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   639
    gen_shuffle_tac (the_context()) true thms i st
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   640
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   641
fun shuffle_meth (thms:thm list) ctxt =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   642
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   643
	val thy = ProofContext.theory_of ctxt
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   644
    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   645
	Method.SIMPLE_METHOD' HEADGOAL (gen_shuffle_tac thy false (map (pair "") thms))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   646
    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   647
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   648
fun search_meth ctxt =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   649
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   650
	val thy = ProofContext.theory_of ctxt
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   651
	val prems = ProofContext.prems_of ctxt
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   652
    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   653
	Method.SIMPLE_METHOD' HEADGOAL (gen_shuffle_tac thy true (map (pair "premise") prems))
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   654
    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   655
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   656
val print_shuffles = ShuffleData.print
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   657
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   658
fun add_shuffle_rule thm thy =
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   659
    let
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   660
	val shuffles = ShuffleData.get thy
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   661
    in
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   662
	if exists (curry Thm.eq_thm thm) shuffles
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   663
	then (warning ((string_of_thm thm) ^ " already known to the shuffler");
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   664
	      thy)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   665
	else ShuffleData.put (thm::shuffles) thy
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   666
    end
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   667
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   668
fun shuffle_attr (thy,thm) = (add_shuffle_rule thm thy,thm)
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   669
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   670
val setup = [Method.add_method ("shuffle_tac",Method.thms_ctxt_args shuffle_meth,"solve goal by shuffling terms around"),
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   671
	     Method.add_method ("search_tac",Method.ctxt_args search_meth,"search for suitable theorems"),
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   672
	     ShuffleData.init,
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   673
	     add_shuffle_rule weaken,
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   674
	     add_shuffle_rule equiv_comm,
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   675
	     add_shuffle_rule imp_comm,
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   676
	     add_shuffle_rule Drule.norm_hhf_eq,
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   677
	     add_shuffle_rule Drule.triv_forall_equality,
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   678
	     Attrib.add_attributes [("shuffle_rule",(Attrib.no_args shuffle_attr,K Attrib.undef_local_attribute),"tell the shuffler about the theorem")]]
a183dec876ab Added HOL proof importer.
skalberg
parents:
diff changeset
   679
end