86 val i = length Ts; |
86 val i = length Ts; |
87 val xs = map (pair "x") Ts; |
87 val xs = map (pair "x") Ts; |
88 val u = list_comb (t, map Bound (i - 1 downto 0)) |
88 val u = list_comb (t, map Bound (i - 1 downto 0)) |
89 in |
89 in |
90 if member (op =) vs a then |
90 if member (op =) vs a then |
91 list_abs (("r", U) :: xs, mk_rlz U $ Bound i $ u) |
91 fold_rev Term.abs (("r", U) :: xs) (mk_rlz U $ Bound i $ u) |
92 else list_abs (xs, mk_rlz Extraction.nullT $ Extraction.nullt $ u) |
92 else |
|
93 fold_rev Term.abs xs (mk_rlz Extraction.nullT $ Extraction.nullt $ u) |
93 end |
94 end |
94 | gen_rvar _ t = t; |
95 | gen_rvar _ t = t; |
95 |
96 |
96 fun mk_realizes_eqn n vs nparms intrs = |
97 fun mk_realizes_eqn n vs nparms intrs = |
97 let |
98 let |
162 else if is_rec prem then |
163 else if is_rec prem then |
163 if is_meta prem then |
164 if is_meta prem then |
164 let |
165 let |
165 val prem' :: prems' = prems; |
166 val prem' :: prems' = prems; |
166 val U = Extraction.etype_of thy vs [] prem'; |
167 val U = Extraction.etype_of thy vs [] prem'; |
167 in if U = Extraction.nullT |
168 in |
|
169 if U = Extraction.nullT |
168 then fun_of (Free (x, T) :: ts) |
170 then fun_of (Free (x, T) :: ts) |
169 (Free (r, binder_types T ---> HOLogic.unitT) :: rts) |
171 (Free (r, binder_types T ---> HOLogic.unitT) :: rts) |
170 (Free (x, T) :: args) (x :: r :: used) prems' |
172 (Free (x, T) :: args) (x :: r :: used) prems' |
171 else fun_of (Free (x, T) :: ts) (Free (r, U) :: rts) |
173 else fun_of (Free (x, T) :: ts) (Free (r, U) :: rts) |
172 (Free (r, U) :: Free (x, T) :: args) (x :: r :: used) prems' |
174 (Free (r, U) :: Free (x, T) :: args) (x :: r :: used) prems' |
173 end |
175 end |
174 else (case strip_type T of |
176 else |
|
177 (case strip_type T of |
175 (Ts, Type (@{type_name Product_Type.prod}, [T1, T2])) => |
178 (Ts, Type (@{type_name Product_Type.prod}, [T1, T2])) => |
176 let |
179 let |
177 val fx = Free (x, Ts ---> T1); |
180 val fx = Free (x, Ts ---> T1); |
178 val fr = Free (r, Ts ---> T2); |
181 val fr = Free (r, Ts ---> T2); |
179 val bs = map Bound (length Ts - 1 downto 0); |
182 val bs = map Bound (length Ts - 1 downto 0); |
180 val t = list_abs (map (pair "z") Ts, |
183 val t = |
181 HOLogic.mk_prod (list_comb (fx, bs), list_comb (fr, bs))) |
184 fold_rev (Term.abs o pair "z") Ts |
182 in fun_of (fx :: ts) (fr :: rts) (t::args) |
185 (HOLogic.mk_prod (list_comb (fx, bs), list_comb (fr, bs))); |
183 (x :: r :: used) prems |
186 in fun_of (fx :: ts) (fr :: rts) (t::args) (x :: r :: used) prems end |
184 end |
|
185 | (Ts, U) => fun_of (Free (x, T) :: ts) |
187 | (Ts, U) => fun_of (Free (x, T) :: ts) |
186 (Free (r, binder_types T ---> HOLogic.unitT) :: rts) |
188 (Free (r, binder_types T ---> HOLogic.unitT) :: rts) |
187 (Free (x, T) :: args) (x :: r :: used) prems) |
189 (Free (x, T) :: args) (x :: r :: used) prems) |
188 else fun_of (Free (x, T) :: ts) rts (Free (x, T) :: args) |
190 else fun_of (Free (x, T) :: ts) rts (Free (x, T) :: args) |
189 (x :: used) prems |
191 (x :: used) prems |
437 val p = Logic.list_implies |
439 val p = Logic.list_implies |
438 (map reorder1 (prems ~~ intrs) @ [prem], concl_of elim); |
440 (map reorder1 (prems ~~ intrs) @ [prem], concl_of elim); |
439 val T' = Extraction.etype_of thy (vs @ Ps) [] p; |
441 val T' = Extraction.etype_of thy (vs @ Ps) [] p; |
440 val T = if dummy then (HOLogic.unitT --> body_type T') --> T' else T'; |
442 val T = if dummy then (HOLogic.unitT --> body_type T') --> T' else T'; |
441 val Ts = map (Extraction.etype_of thy (vs @ Ps) []) (prems_of elim); |
443 val Ts = map (Extraction.etype_of thy (vs @ Ps) []) (prems_of elim); |
442 val r = if null Ps then Extraction.nullt |
444 val r = |
443 else list_abs (map (pair "x") Ts, list_comb (Const (case_name, T), |
445 if null Ps then Extraction.nullt |
444 (if dummy then |
446 else |
445 [Abs ("x", HOLogic.unitT, Const (@{const_name default}, body_type T))] |
447 fold_rev (Term.abs o pair "x") Ts |
446 else []) @ |
448 (list_comb (Const (case_name, T), |
447 map reorder2 (intrs ~~ (length prems - 1 downto 0)) @ |
449 (if dummy then |
448 [Bound (length prems)])); |
450 [Abs ("x", HOLogic.unitT, Const (@{const_name default}, body_type T))] |
|
451 else []) @ |
|
452 map reorder2 (intrs ~~ (length prems - 1 downto 0)) @ |
|
453 [Bound (length prems)])); |
449 val rlz = Extraction.realizes_of thy (vs @ Ps) r (prop_of elim); |
454 val rlz = Extraction.realizes_of thy (vs @ Ps) r (prop_of elim); |
450 val rlz' = attach_typeS (strip_all (Logic.unvarify_global rlz)); |
455 val rlz' = attach_typeS (strip_all (Logic.unvarify_global rlz)); |
451 val rews = map mk_meta_eq case_thms; |
456 val rews = map mk_meta_eq case_thms; |
452 val thm = Goal.prove_global thy [] |
457 val thm = Goal.prove_global thy [] |
453 (Logic.strip_imp_prems rlz') (Logic.strip_imp_concl rlz') (fn {prems, ...} => EVERY |
458 (Logic.strip_imp_prems rlz') (Logic.strip_imp_concl rlz') (fn {prems, ...} => EVERY |