264 | _ => body); |
264 | _ => body); |
265 |
265 |
266 val mk_Abst = fold_rev (fn (s, T:typ) => fn prf => Abst (s, NONE, prf)); |
266 val mk_Abst = fold_rev (fn (s, T:typ) => fn prf => Abst (s, NONE, prf)); |
267 fun mk_AbsP (i, prf) = funpow i (fn prf => AbsP ("H", NONE, prf)) prf; |
267 fun mk_AbsP (i, prf) = funpow i (fn prf => AbsP ("H", NONE, prf)) prf; |
268 |
268 |
269 fun apsome f NONE = raise Same.SAME |
|
270 | apsome f (SOME x) = (case f x of NONE => raise Same.SAME | some => some); |
|
271 |
|
272 fun apsome' f NONE = raise Same.SAME |
|
273 | apsome' f (SOME x) = SOME (f x); |
|
274 |
|
275 fun map_proof_terms_option f g = |
269 fun map_proof_terms_option f g = |
276 let |
270 let |
277 fun map_typs (T :: Ts) = |
271 val term = Same.function f; |
278 (case g T of |
272 val typ = Same.function g; |
279 NONE => T :: map_typs Ts |
273 val typs = Same.map typ; |
280 | SOME T' => T' :: (map_typs Ts handle Same.SAME => Ts)) |
274 |
281 | map_typs [] = raise Same.SAME; |
275 fun proof (Abst (s, T, prf)) = |
282 |
276 (Abst (s, Same.map_option typ T, Same.commit proof prf) |
283 fun mapp (Abst (s, T, prf)) = (Abst (s, apsome g T, mapph prf) |
277 handle Same.SAME => Abst (s, T, proof prf)) |
284 handle Same.SAME => Abst (s, T, mapp prf)) |
278 | proof (AbsP (s, t, prf)) = |
285 | mapp (AbsP (s, t, prf)) = (AbsP (s, apsome f t, mapph prf) |
279 (AbsP (s, Same.map_option term t, Same.commit proof prf) |
286 handle Same.SAME => AbsP (s, t, mapp prf)) |
280 handle Same.SAME => AbsP (s, t, proof prf)) |
287 | mapp (prf % t) = (mapp prf % (apsome f t handle Same.SAME => t) |
281 | proof (prf % t) = |
288 handle Same.SAME => prf % apsome f t) |
282 (proof prf % Same.commit (Same.map_option term) t |
289 | mapp (prf1 %% prf2) = (mapp prf1 %% mapph prf2 |
283 handle Same.SAME => prf % Same.map_option term t) |
290 handle Same.SAME => prf1 %% mapp prf2) |
284 | proof (prf1 %% prf2) = |
291 | mapp (PAxm (a, prop, SOME Ts)) = PAxm (a, prop, SOME (map_typs Ts)) |
285 (proof prf1 %% Same.commit proof prf2 |
292 | mapp (OfClass (T, c)) = OfClass (apsome g (SOME T) |> the, c) |
286 handle Same.SAME => prf1 %% proof prf2) |
293 | mapp (Oracle (a, prop, SOME Ts)) = Oracle (a, prop, SOME (map_typs Ts)) |
287 | proof (PAxm (a, prop, SOME Ts)) = PAxm (a, prop, SOME (typs Ts)) |
294 | mapp (Promise (i, prop, Ts)) = Promise (i, prop, map_typs Ts) |
288 | proof (OfClass (T, c)) = OfClass (typ T, c) |
295 | mapp (PThm (i, ((a, prop, SOME Ts), body))) = |
289 | proof (Oracle (a, prop, SOME Ts)) = Oracle (a, prop, SOME (typs Ts)) |
296 PThm (i, ((a, prop, SOME (map_typs Ts)), body)) |
290 | proof (Promise (i, prop, Ts)) = Promise (i, prop, typs Ts) |
297 | mapp _ = raise Same.SAME |
291 | proof (PThm (i, ((a, prop, SOME Ts), body))) = PThm (i, ((a, prop, SOME (typs Ts)), body)) |
298 and mapph prf = (mapp prf handle Same.SAME => prf) |
292 | proof _ = raise Same.SAME; |
299 |
293 in Same.commit proof end; |
300 in mapph end; |
|
301 |
294 |
302 fun same eq f x = |
295 fun same eq f x = |
303 let val x' = f x |
296 let val x' = f x |
304 in if eq (x, x') then raise Same.SAME else x' end; |
297 in if eq (x, x') then raise Same.SAME else x' end; |
305 |
298 |
359 | f $ t => (abst' lev f $ absth' lev t handle Same.SAME => f $ abst' lev t) |
352 | f $ t => (abst' lev f $ absth' lev t handle Same.SAME => f $ abst' lev t) |
360 | _ => raise Same.SAME) |
353 | _ => raise Same.SAME) |
361 and absth' lev t = (abst' lev t handle Same.SAME => t); |
354 and absth' lev t = (abst' lev t handle Same.SAME => t); |
362 |
355 |
363 fun abst lev (AbsP (a, t, prf)) = |
356 fun abst lev (AbsP (a, t, prf)) = |
364 (AbsP (a, apsome' (abst' lev) t, absth lev prf) |
357 (AbsP (a, Same.map_option (abst' lev) t, absth lev prf) |
365 handle Same.SAME => AbsP (a, t, abst lev prf)) |
358 handle Same.SAME => AbsP (a, t, abst lev prf)) |
366 | abst lev (Abst (a, T, prf)) = Abst (a, T, abst (lev + 1) prf) |
359 | abst lev (Abst (a, T, prf)) = Abst (a, T, abst (lev + 1) prf) |
367 | abst lev (prf1 %% prf2) = (abst lev prf1 %% absth lev prf2 |
360 | abst lev (prf1 %% prf2) = (abst lev prf1 %% absth lev prf2 |
368 handle Same.SAME => prf1 %% abst lev prf2) |
361 handle Same.SAME => prf1 %% abst lev prf2) |
369 | abst lev (prf % t) = (abst lev prf % Option.map (absth' lev) t |
362 | abst lev (prf % t) = (abst lev prf % Option.map (absth' lev) t |
370 handle Same.SAME => prf % apsome' (abst' lev) t) |
363 handle Same.SAME => prf % Same.map_option (abst' lev) t) |
371 | abst _ _ = raise Same.SAME |
364 | abst _ _ = raise Same.SAME |
372 and absth lev prf = (abst lev prf handle Same.SAME => prf) |
365 and absth lev prf = (abst lev prf handle Same.SAME => prf); |
373 |
366 |
374 in absth 0 end; |
367 in absth 0 end; |
375 |
368 |
376 |
369 |
377 (*increments a proof term's non-local bound variables |
370 (*increments a proof term's non-local bound variables |
382 fun incr_bv' inct tlev t = incr_bv (inct, tlev, t); |
375 fun incr_bv' inct tlev t = incr_bv (inct, tlev, t); |
383 |
376 |
384 fun prf_incr_bv' incP inct Plev tlev (PBound i) = |
377 fun prf_incr_bv' incP inct Plev tlev (PBound i) = |
385 if i >= Plev then PBound (i+incP) else raise Same.SAME |
378 if i >= Plev then PBound (i+incP) else raise Same.SAME |
386 | prf_incr_bv' incP inct Plev tlev (AbsP (a, t, body)) = |
379 | prf_incr_bv' incP inct Plev tlev (AbsP (a, t, body)) = |
387 (AbsP (a, apsome' (same (op =) (incr_bv' inct tlev)) t, |
380 (AbsP (a, Same.map_option (same (op =) (incr_bv' inct tlev)) t, |
388 prf_incr_bv incP inct (Plev+1) tlev body) handle Same.SAME => |
381 prf_incr_bv incP inct (Plev+1) tlev body) handle Same.SAME => |
389 AbsP (a, t, prf_incr_bv' incP inct (Plev+1) tlev body)) |
382 AbsP (a, t, prf_incr_bv' incP inct (Plev+1) tlev body)) |
390 | prf_incr_bv' incP inct Plev tlev (Abst (a, T, body)) = |
383 | prf_incr_bv' incP inct Plev tlev (Abst (a, T, body)) = |
391 Abst (a, T, prf_incr_bv' incP inct Plev (tlev+1) body) |
384 Abst (a, T, prf_incr_bv' incP inct Plev (tlev+1) body) |
392 | prf_incr_bv' incP inct Plev tlev (prf %% prf') = |
385 | prf_incr_bv' incP inct Plev tlev (prf %% prf') = |
393 (prf_incr_bv' incP inct Plev tlev prf %% prf_incr_bv incP inct Plev tlev prf' |
386 (prf_incr_bv' incP inct Plev tlev prf %% prf_incr_bv incP inct Plev tlev prf' |
394 handle Same.SAME => prf %% prf_incr_bv' incP inct Plev tlev prf') |
387 handle Same.SAME => prf %% prf_incr_bv' incP inct Plev tlev prf') |
395 | prf_incr_bv' incP inct Plev tlev (prf % t) = |
388 | prf_incr_bv' incP inct Plev tlev (prf % t) = |
396 (prf_incr_bv' incP inct Plev tlev prf % Option.map (incr_bv' inct tlev) t |
389 (prf_incr_bv' incP inct Plev tlev prf % Option.map (incr_bv' inct tlev) t |
397 handle Same.SAME => prf % apsome' (same (op =) (incr_bv' inct tlev)) t) |
390 handle Same.SAME => prf % Same.map_option (same (op =) (incr_bv' inct tlev)) t) |
398 | prf_incr_bv' _ _ _ _ _ = raise Same.SAME |
391 | prf_incr_bv' _ _ _ _ _ = raise Same.SAME |
399 and prf_incr_bv incP inct Plev tlev prf = |
392 and prf_incr_bv incP inct Plev tlev prf = |
400 (prf_incr_bv' incP inct Plev tlev prf handle Same.SAME => prf); |
393 (prf_incr_bv' incP inct Plev tlev prf handle Same.SAME => prf); |
401 |
394 |
402 fun incr_pboundvars 0 0 prf = prf |
395 fun incr_pboundvars 0 0 prf = prf |
459 (msg s; f env (del_conflicting_vars env t)); |
452 (msg s; f env (del_conflicting_vars env t)); |
460 fun htypeT f T = f envT T handle TYPE (s, _, _) => |
453 fun htypeT f T = f envT T handle TYPE (s, _, _) => |
461 (msg s; f envT (del_conflicting_tvars envT T)); |
454 (msg s; f envT (del_conflicting_tvars envT T)); |
462 fun htypeTs f Ts = f envT Ts handle TYPE (s, _, _) => |
455 fun htypeTs f Ts = f envT Ts handle TYPE (s, _, _) => |
463 (msg s; f envT (map (del_conflicting_tvars envT) Ts)); |
456 (msg s; f envT (map (del_conflicting_tvars envT) Ts)); |
|
457 |
464 fun norm (Abst (s, T, prf)) = |
458 fun norm (Abst (s, T, prf)) = |
465 (Abst (s, apsome' (htypeT Envir.norm_type_same) T, Same.commit norm prf) |
459 (Abst (s, Same.map_option (htypeT Envir.norm_type_same) T, Same.commit norm prf) |
466 handle Same.SAME => Abst (s, T, norm prf)) |
460 handle Same.SAME => Abst (s, T, norm prf)) |
467 | norm (AbsP (s, t, prf)) = |
461 | norm (AbsP (s, t, prf)) = |
468 (AbsP (s, apsome' (htype Envir.norm_term_same) t, Same.commit norm prf) |
462 (AbsP (s, Same.map_option (htype Envir.norm_term_same) t, Same.commit norm prf) |
469 handle Same.SAME => AbsP (s, t, norm prf)) |
463 handle Same.SAME => AbsP (s, t, norm prf)) |
470 | norm (prf % t) = |
464 | norm (prf % t) = |
471 (norm prf % Option.map (htype Envir.norm_term) t |
465 (norm prf % Option.map (htype Envir.norm_term) t |
472 handle Same.SAME => prf % apsome' (htype Envir.norm_term_same) t) |
466 handle Same.SAME => prf % Same.map_option (htype Envir.norm_term_same) t) |
473 | norm (prf1 %% prf2) = |
467 | norm (prf1 %% prf2) = |
474 (norm prf1 %% Same.commit norm prf2 |
468 (norm prf1 %% Same.commit norm prf2 |
475 handle Same.SAME => prf1 %% norm prf2) |
469 handle Same.SAME => prf1 %% norm prf2) |
476 | norm (PAxm (s, prop, Ts)) = |
470 | norm (PAxm (s, prop, Ts)) = |
477 PAxm (s, prop, apsome' (htypeTs Envir.norm_types_same) Ts) |
471 PAxm (s, prop, Same.map_option (htypeTs Envir.norm_types_same) Ts) |
478 | norm (OfClass (T, c)) = |
472 | norm (OfClass (T, c)) = |
479 OfClass (htypeT Envir.norm_type_same T, c) |
473 OfClass (htypeT Envir.norm_type_same T, c) |
480 | norm (Oracle (s, prop, Ts)) = |
474 | norm (Oracle (s, prop, Ts)) = |
481 Oracle (s, prop, apsome' (htypeTs Envir.norm_types_same) Ts) |
475 Oracle (s, prop, Same.map_option (htypeTs Envir.norm_types_same) Ts) |
482 | norm (Promise (i, prop, Ts)) = |
476 | norm (Promise (i, prop, Ts)) = |
483 Promise (i, prop, htypeTs Envir.norm_types_same Ts) |
477 Promise (i, prop, htypeTs Envir.norm_types_same Ts) |
484 | norm (PThm (i, ((s, t, Ts), body))) = |
478 | norm (PThm (i, ((s, t, Ts), body))) = |
485 PThm (i, ((s, t, apsome' (htypeTs Envir.norm_types_same) Ts), body)) |
479 PThm (i, ((s, t, Same.map_option (htypeTs Envir.norm_types_same) Ts), body)) |
486 | norm _ = raise Same.SAME; |
480 | norm _ = raise Same.SAME; |
487 in Same.commit norm end; |
481 in Same.commit norm end; |
488 |
482 |
489 |
483 |
490 (***** Remove some types in proof term (to save space) *****) |
484 (***** Remove some types in proof term (to save space) *****) |
514 | subst' lev (f $ t) = (subst' lev f $ substh' lev t |
508 | subst' lev (f $ t) = (subst' lev f $ substh' lev t |
515 handle Same.SAME => f $ subst' lev t) |
509 handle Same.SAME => f $ subst' lev t) |
516 | subst' _ _ = raise Same.SAME |
510 | subst' _ _ = raise Same.SAME |
517 and substh' lev t = (subst' lev t handle Same.SAME => t); |
511 and substh' lev t = (subst' lev t handle Same.SAME => t); |
518 |
512 |
519 fun subst lev (AbsP (a, t, body)) = (AbsP (a, apsome' (subst' lev) t, substh lev body) |
513 fun subst lev (AbsP (a, t, body)) = (AbsP (a, Same.map_option (subst' lev) t, substh lev body) |
520 handle Same.SAME => AbsP (a, t, subst lev body)) |
514 handle Same.SAME => AbsP (a, t, subst lev body)) |
521 | subst lev (Abst (a, T, body)) = Abst (a, T, subst (lev+1) body) |
515 | subst lev (Abst (a, T, body)) = Abst (a, T, subst (lev+1) body) |
522 | subst lev (prf %% prf') = (subst lev prf %% substh lev prf' |
516 | subst lev (prf %% prf') = (subst lev prf %% substh lev prf' |
523 handle Same.SAME => prf %% subst lev prf') |
517 handle Same.SAME => prf %% subst lev prf') |
524 | subst lev (prf % t) = (subst lev prf % Option.map (substh' lev) t |
518 | subst lev (prf % t) = (subst lev prf % Option.map (substh' lev) t |
525 handle Same.SAME => prf % apsome' (subst' lev) t) |
519 handle Same.SAME => prf % Same.map_option (subst' lev) t) |
526 | subst _ _ = raise Same.SAME |
520 | subst _ _ = raise Same.SAME |
527 and substh lev prf = (subst lev prf handle Same.SAME => prf) |
521 and substh lev prf = (subst lev prf handle Same.SAME => prf); |
528 in case args of [] => prf | _ => substh 0 prf end; |
522 in case args of [] => prf | _ => substh 0 prf end; |
529 |
523 |
530 fun prf_subst_pbounds args prf = |
524 fun prf_subst_pbounds args prf = |
531 let |
525 let |
532 val n = length args; |
526 val n = length args; |
602 |
596 |
603 fun implies_intr_proof h prf = |
597 fun implies_intr_proof h prf = |
604 let |
598 let |
605 fun abshyp i (Hyp t) = if h aconv t then PBound i else raise Same.SAME |
599 fun abshyp i (Hyp t) = if h aconv t then PBound i else raise Same.SAME |
606 | abshyp i (Abst (s, T, prf)) = Abst (s, T, abshyp i prf) |
600 | abshyp i (Abst (s, T, prf)) = Abst (s, T, abshyp i prf) |
607 | abshyp i (AbsP (s, t, prf)) = AbsP (s, t, abshyp (i+1) prf) |
601 | abshyp i (AbsP (s, t, prf)) = AbsP (s, t, abshyp (i + 1) prf) |
608 | abshyp i (prf % t) = abshyp i prf % t |
602 | abshyp i (prf % t) = abshyp i prf % t |
609 | abshyp i (prf1 %% prf2) = (abshyp i prf1 %% abshyph i prf2 |
603 | abshyp i (prf1 %% prf2) = |
610 handle Same.SAME => prf1 %% abshyp i prf2) |
604 (abshyp i prf1 %% abshyph i prf2 |
|
605 handle Same.SAME => prf1 %% abshyp i prf2) |
611 | abshyp _ _ = raise Same.SAME |
606 | abshyp _ _ = raise Same.SAME |
612 and abshyph i prf = (abshyp i prf handle Same.SAME => prf) |
607 and abshyph i prf = (abshyp i prf handle Same.SAME => prf); |
613 in |
608 in |
614 AbsP ("H", NONE (*h*), abshyph 0 prf) |
609 AbsP ("H", NONE (*h*), abshyph 0 prf) |
615 end; |
610 end; |
616 |
611 |
617 |
612 |
626 let |
621 let |
627 val fs = Term.fold_types (Term.fold_atyps |
622 val fs = Term.fold_types (Term.fold_atyps |
628 (fn TFree v => if member (op =) fixed v then I else insert (op =) v | _ => I)) t []; |
623 (fn TFree v => if member (op =) fixed v then I else insert (op =) v | _ => I)) t []; |
629 val used = Name.context |
624 val used = Name.context |
630 |> fold_types (fold_atyps (fn TVar ((a, _), _) => Name.declare a | _ => I)) t; |
625 |> fold_types (fold_atyps (fn TVar ((a, _), _) => Name.declare a | _ => I)) t; |
631 val fmap = fs ~~ (#1 (Name.variants (map fst fs) used)); |
626 val fmap = fs ~~ #1 (Name.variants (map fst fs) used); |
632 fun thaw (f as (a, S)) = |
627 fun thaw (f as (a, S)) = |
633 (case AList.lookup (op =) fmap f of |
628 (case AList.lookup (op =) fmap f of |
634 NONE => TFree f |
629 NONE => TFree f |
635 | SOME b => TVar ((b, 0), S)); |
630 | SOME b => TVar ((b, 0), S)); |
636 in map_proof_terms (map_types (map_type_tfree thaw)) (map_type_tfree thaw) prf end; |
631 in map_proof_terms (map_types (map_type_tfree thaw)) (map_type_tfree thaw) prf end; |
707 |
702 |
708 (***** lifting *****) |
703 (***** lifting *****) |
709 |
704 |
710 fun lift_proof Bi inc prop prf = |
705 fun lift_proof Bi inc prop prf = |
711 let |
706 let |
712 fun lift'' Us Ts t = strip_abs Ts (Logic.incr_indexes (Us, inc) (mk_abs Ts t)); |
707 fun lift'' Us Ts t = |
|
708 strip_abs Ts (Logic.incr_indexes (Us, inc) (mk_abs Ts t)); |
713 |
709 |
714 fun lift' Us Ts (Abst (s, T, prf)) = |
710 fun lift' Us Ts (Abst (s, T, prf)) = |
715 (Abst (s, apsome' (same (op =) (Logic.incr_tvar inc)) T, lifth' Us (dummyT::Ts) prf) |
711 (Abst (s, Same.map_option (Logic.incr_tvar_same inc) T, lifth' Us (dummyT::Ts) prf) |
716 handle Same.SAME => Abst (s, T, lift' Us (dummyT::Ts) prf)) |
712 handle Same.SAME => Abst (s, T, lift' Us (dummyT::Ts) prf)) |
717 | lift' Us Ts (AbsP (s, t, prf)) = |
713 | lift' Us Ts (AbsP (s, t, prf)) = |
718 (AbsP (s, apsome' (same (op =) (lift'' Us Ts)) t, lifth' Us Ts prf) |
714 (AbsP (s, Same.map_option (same (op =) (lift'' Us Ts)) t, lifth' Us Ts prf) |
719 handle Same.SAME => AbsP (s, t, lift' Us Ts prf)) |
715 handle Same.SAME => AbsP (s, t, lift' Us Ts prf)) |
720 | lift' Us Ts (prf % t) = (lift' Us Ts prf % Option.map (lift'' Us Ts) t |
716 | lift' Us Ts (prf % t) = (lift' Us Ts prf % Option.map (lift'' Us Ts) t |
721 handle Same.SAME => prf % apsome' (same (op =) (lift'' Us Ts)) t) |
717 handle Same.SAME => prf % Same.map_option (same (op =) (lift'' Us Ts)) t) |
722 | lift' Us Ts (prf1 %% prf2) = (lift' Us Ts prf1 %% lifth' Us Ts prf2 |
718 | lift' Us Ts (prf1 %% prf2) = (lift' Us Ts prf1 %% lifth' Us Ts prf2 |
723 handle Same.SAME => prf1 %% lift' Us Ts prf2) |
719 handle Same.SAME => prf1 %% lift' Us Ts prf2) |
724 | lift' _ _ (PAxm (s, prop, Ts)) = |
720 | lift' _ _ (PAxm (s, prop, Ts)) = |
725 PAxm (s, prop, apsome' (same (op =) (map (Logic.incr_tvar inc))) Ts) |
721 PAxm (s, prop, (Same.map_option o Same.map) (Logic.incr_tvar_same inc) Ts) |
726 | lift' _ _ (OfClass (T, c)) = |
722 | lift' _ _ (OfClass (T, c)) = |
727 OfClass (same (op =) (Logic.incr_tvar inc) T, c) |
723 OfClass (Logic.incr_tvar_same inc T, c) |
728 | lift' _ _ (Oracle (s, prop, Ts)) = |
724 | lift' _ _ (Oracle (s, prop, Ts)) = |
729 Oracle (s, prop, apsome' (same (op =) (map (Logic.incr_tvar inc))) Ts) |
725 Oracle (s, prop, (Same.map_option o Same.map) (Logic.incr_tvar_same inc) Ts) |
730 | lift' _ _ (Promise (i, prop, Ts)) = |
726 | lift' _ _ (Promise (i, prop, Ts)) = |
731 Promise (i, prop, same (op =) (map (Logic.incr_tvar inc)) Ts) |
727 Promise (i, prop, Same.map (Logic.incr_tvar_same inc) Ts) |
732 | lift' _ _ (PThm (i, ((s, prop, Ts), body))) = |
728 | lift' _ _ (PThm (i, ((s, prop, Ts), body))) = |
733 PThm (i, ((s, prop, apsome' (same (op =) (map (Logic.incr_tvar inc))) Ts), body)) |
729 PThm (i, ((s, prop, (Same.map_option o Same.map) (Logic.incr_tvar inc) Ts), body)) |
734 | lift' _ _ _ = raise Same.SAME |
730 | lift' _ _ _ = raise Same.SAME |
735 and lifth' Us Ts prf = (lift' Us Ts prf handle Same.SAME => prf); |
731 and lifth' Us Ts prf = (lift' Us Ts prf handle Same.SAME => prf); |
736 |
732 |
737 val ps = map (Logic.lift_all inc Bi) (Logic.strip_imp_prems prop); |
733 val ps = map (Logic.lift_all inc Bi) (Logic.strip_imp_prems prop); |
738 val k = length ps; |
734 val k = length ps; |