theory Rsp

imports Abs

begin

ML {*

fun define_quotient_type args tac ctxt =

let

  val mthd = Method.SIMPLE_METHOD tac

  val mthdt = Method.Basic (fn _ => mthd)

  val bymt = Proof.global_terminal_proof (mthdt, NONE)

in

  bymt (Quotient_Type.quotient_type args ctxt)

end

*}

ML {*

fun const_rsp lthy const =

let

  val nty = fastype_of (Quotient_Term.quotient_lift_const ("", const) lthy)

  val rel = Quotient_Term.equiv_relation_chk lthy (fastype_of const, nty);

in

  HOLogic.mk_Trueprop (rel $ const $ const)

end

*}

(* Replaces bounds by frees and meta implications by implications *)

ML {*

fun prepare_goal trm =

let

  val vars = strip_all_vars trm

  val fs = rev (map Free vars)

  val (fixes, no_alls) = ((map fst vars), subst_bounds (fs, (strip_all_body trm)))

  val prems = map HOLogic.dest_Trueprop (Logic.strip_imp_prems no_alls)

  val concl = HOLogic.dest_Trueprop (Logic.strip_imp_concl no_alls)

in

  (fixes, fold (curry HOLogic.mk_imp) prems concl)

end

*}

ML {*

fun get_rsp_goal thy trm =

let

  val goalstate = Goal.init (cterm_of thy trm);

  val tac = REPEAT o rtac @{thm fun_rel_id};

in

  case (SINGLE (tac 1) goalstate) of

    NONE => error "rsp_goal failed"

  | SOME th => prepare_goal (term_of (cprem_of th 1))

end

*}

ML {*

fun repeat_mp thm = repeat_mp (mp OF [thm]) handle THM _ => thm

*}

ML {*

fun prove_const_rsp bind consts tac ctxt =

let

  val rsp_goals = map (const_rsp ctxt) consts

  val thy = ProofContext.theory_of ctxt

  val (fixed, user_goals) = split_list (map (get_rsp_goal thy) rsp_goals)

  val fixed' = distinct (op =) (flat fixed)

  val user_goal = HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj user_goals)

  val user_thm = Goal.prove ctxt fixed' [] user_goal tac

  val user_thms = map repeat_mp (HOLogic.conj_elims user_thm)

  fun tac _ = (REPEAT o rtac @{thm fun_rel_id} THEN' resolve_tac user_thms THEN_ALL_NEW atac) 1

  val rsp_thms = map (fn gl => Goal.prove ctxt [] [] gl tac) rsp_goals

in

   ctxt

|> snd o Local_Theory.note 

  ((Binding.empty, [Attrib.internal (fn _ => Quotient_Info.rsp_rules_add)]), rsp_thms)

|> Local_Theory.note ((bind, []), user_thms)

end

*}

ML {*

fun fvbv_rsp_tac induct fvbv_simps =

  ((((rtac impI THEN' etac induct) ORELSE' rtac induct) THEN_ALL_NEW

  (TRY o rtac @{thm TrueI})) THEN_ALL_NEW

  asm_full_simp_tac

  (HOL_ss addsimps (@{thm alpha_gen} :: fvbv_simps))

  THEN_ALL_NEW (REPEAT o eresolve_tac [conjE, exE] THEN'

  asm_full_simp_tac

  (HOL_ss addsimps (@{thm alpha_gen} :: fvbv_simps))))

*}

ML {*

  fun all_eqvts ctxt =

    Nominal_ThmDecls.get_eqvts_thms ctxt @ Nominal_ThmDecls.get_eqvts_raw_thms ctxt

  val split_conjs = REPEAT o etac conjE THEN' TRY o REPEAT_ALL_NEW (CHANGED o rtac conjI)

*}

ML {*

fun constr_rsp_tac inj rsp equivps =

let

  val reflps = map (fn x => @{thm equivp_reflp} OF [x]) equivps

in

  REPEAT o rtac impI THEN'

  simp_tac (HOL_ss addsimps inj) THEN' split_conjs THEN_ALL_NEW

  (asm_simp_tac HOL_ss THEN_ALL_NEW (

   rtac @{thm exI[of _ "0 :: perm"]} THEN'

   asm_full_simp_tac (HOL_ss addsimps (rsp @ reflps @

     @{thms alpha_gen fresh_star_def fresh_zero_perm permute_zero ball_triv}))

  ))

end

*}

(* Testing code

local_setup {* snd o prove_const_rsp @{binding fv_rtrm2_rsp} [@{term rbv2}]

  (fn _ => fv_rsp_tac @{thm alpha_rtrm2_alpha_rassign.inducts(2)} @{thms fv_rtrm2_fv_rassign.simps} 1) *}*)

(*ML {*

  val rsp_goals = map (const_rsp @{context}) [@{term rbv2}]

  val (fixed, user_goals) = split_list (map (get_rsp_goal @{theory}) rsp_goals)

  val fixed' = distinct (op =) (flat fixed)

  val user_goal = HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj user_goals)

*}

prove ug: {* user_goal *}

ML_prf {*

val induct = @{thm alpha_rtrm2_alpha_rassign.inducts(2)}

val fv_simps = @{thms rbv2.simps}

*} 

*)

ML {*

fun ind_tac induct = (rtac impI THEN' etac induct) ORELSE' rtac induct

*}

ML {*

fun build_eqvts_tac induct simps ctxt inds _ = (Datatype_Aux.indtac induct inds THEN_ALL_NEW

    (asm_full_simp_tac (HOL_ss addsimps

      (@{thm atom_eqvt} :: (Nominal_ThmDecls.get_eqvts_thms ctxt) @ (Nominal_ThmDecls.get_eqvts_raw_thms ctxt) @ simps)))) 1

*}

ML {*

fun perm_arg arg =

let

  val ty = fastype_of arg

in

  Const (@{const_name permute}, @{typ perm} --> ty --> ty)

end

*}

ML {*

fun build_eqvts bind funs tac ctxt =

let

  val pi = Free ("p", @{typ perm});

  val types = map (domain_type o fastype_of) funs;

  val indnames = Name.variant_list ["p"] (Datatype_Prop.make_tnames types);

  val args = map Free (indnames ~~ types);

  val perm_at = @{term "permute :: perm \<Rightarrow> atom set \<Rightarrow> atom set"}

  fun eqvtc (fnctn, arg) =

    HOLogic.mk_eq ((perm_at $ pi $ (fnctn $ arg)), (fnctn $ (perm_arg arg $ pi $ arg)))

  val gl = HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj (map eqvtc (funs ~~ args)))

  val thm = Goal.prove ctxt ("p" :: indnames) [] gl (tac indnames)

  val thms = HOLogic.conj_elims thm

in

  Local_Theory.note ((bind, [Attrib.internal (fn _ => Nominal_ThmDecls.eqvt_add)]), thms) ctxt

end

*}

lemma exi: "\<exists>(pi :: perm). P pi \<Longrightarrow> (\<And>(p :: perm). P p \<Longrightarrow> Q (pi \<bullet> p)) \<Longrightarrow> \<exists>pi. Q pi"

apply (erule exE)

apply (rule_tac x="pi \<bullet> pia" in exI)

by auto

ML {*

fun mk_minimal_ss ctxt =

  Simplifier.context ctxt empty_ss

    setsubgoaler asm_simp_tac

    setmksimps (mksimps [])

*}

ML {*

fun alpha_eqvt_tac induct simps ctxt =

  ind_tac induct THEN_ALL_NEW

  simp_tac ((mk_minimal_ss ctxt) addsimps simps) THEN_ALL_NEW

  REPEAT o etac @{thm exi[of _ _ "p"]} THEN' split_conjs THEN_ALL_NEW

  asm_full_simp_tac (HOL_ss addsimps (all_eqvts ctxt @ simps)) THEN_ALL_NEW

  asm_full_simp_tac (HOL_ss addsimps 

    @{thms supp_eqvt[symmetric] inter_eqvt[symmetric] empty_eqvt alpha_gen}) THEN_ALL_NEW

  (split_conjs THEN_ALL_NEW TRY o resolve_tac

    @{thms fresh_star_permute_iff[of "- p", THEN iffD1] permute_eq_iff[of "- p", THEN iffD1]})

  THEN_ALL_NEW

*}

ML {*

fun build_alpha_eqvt alpha names =

let

  val pi = Free ("p", @{typ perm});

  val (tys, _) = strip_type (fastype_of alpha)

  val indnames = Name.variant_list names (Datatype_Prop.make_tnames (map body_type tys));

  val args = map Free (indnames ~~ tys);

  val perm_args = map (fn x => perm_arg x $ pi $ x) args

in

  (HOLogic.mk_imp (list_comb (alpha, args), list_comb (alpha, perm_args)), indnames @ names)

end

*}

ML {* fold_map build_alpha_eqvt *}

ML {*

fun build_alpha_eqvts funs tac ctxt =

let

  val (gls, names) = fold_map build_alpha_eqvt funs ["p"]

  val gl = HOLogic.mk_Trueprop (foldr1 HOLogic.mk_conj gls)

  val thm = Goal.prove ctxt names [] gl tac

in

  map (fn x => mp OF [x]) (HOLogic.conj_elims thm)

end

*}

ML {*

fun build_bv_eqvt simps inducts (t, n) ctxt =

  build_eqvts Binding.empty [t] (build_eqvts_tac (nth inducts n) simps ctxt) ctxt

*}

end