\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsection \<open>Transport using Identity\<close>
theory Transport_Identity
  imports
    Transport_Bijections
begin

paragraph \<open>Summary\<close>
text \<open>Setup for Transport using the identity transport function.\<close>

locale transport_id =
  fixes L :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
begin

sublocale tbij? : transport_bijection L L id id
  by (intro transport_bijection.intro) auto

interpretation transport L L id id .

lemma Galois_eq_left: "(\<^bsub>L\<^esub>\<lessapprox>) = (\<le>\<^bsub>L\<^esub>)"
  by (intro ext iffI) auto

end

locale transport_reflexive_on_in_field_id =
  fixes L :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  assumes reflexive_on_in_field: "reflexive_on (in_field L) L"
begin

sublocale trefl_bij? : transport_reflexive_on_in_field_bijection L L id id
  using reflexive_on_in_field by unfold_locales auto

end

locale transport_preorder_on_in_field_id =
  fixes L :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  assumes preorder_on_in_field: "preorder_on (in_field L) L"
begin

sublocale tpre_bij? : transport_preorder_on_in_field_bijection L L id id
  using preorder_on_in_field by unfold_locales auto

end

locale transport_partial_equivalence_rel_id =
  fixes L :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  assumes partial_equivalence_rel: "partial_equivalence_rel L"
begin

sublocale tper_bij? : transport_partial_equivalence_rel_bijection L L id id
  using partial_equivalence_rel by unfold_locales auto

end

interpretation transport_eq_restrict_id :
  transport_eq_restrict_bijection P P id id for  P :: "'a \<Rightarrow> bool"
  using bijection_on_self_id by (unfold_locales) auto

interpretation transport_eq_id : transport_eq_bijection id id
  using bijection_on_self_id by (unfold_locales) auto

end


theory Chap7ex
  imports Main Chap7_2 Chap7_3
begin

fun assigned :: "com \<Rightarrow> vname set" where
"assigned SKIP = {}"
| "assigned (v ::= va) = {v}"
| "assigned (v;; va) = assigned v \<union> assigned va"
| "assigned (IF v THEN va ELSE vb) = assigned va \<union> assigned vb"
| "assigned (WHILE v DO va) = assigned va"
| "assigned (REPEAT v UNTIL va) = assigned v"
| "assigned (p OR q) = assigned p \<union> assigned q"
| "assigned THROW = {}"
| "assigned (TRY p CATCH c) = assigned p \<union> assigned c"

lemma "\<lbrakk> (c, s) \<Rightarrow> (r, s'); x \<notin> assigned c \<rbrakk> \<Longrightarrow> s x = s' x"
  apply (induct rule: big_step_induct)
  by auto

fun skip :: "com \<Rightarrow> bool" where
"skip SKIP = True"
| "skip (v ::= va) = (\<forall>s. s v = aval va s)"
| "skip (v;; va) = (skip v \<and> skip va)"
| "skip (IF v THEN va ELSE vb) = (skip va \<and> skip vb)"
| "skip (WHILE v DO va) = (\<forall>s. \<not>bval v s)"
| "skip (REPEAT v UNTIL va) = (skip v \<and> (\<forall>s. bval va s))"
| "skip (p OR q) = (skip p \<and> skip q)"
| "skip THROW = False"
| "skip (TRY p CATCH c) = (skip p \<and> skip c)"

lemma "skip c \<Longrightarrow> c \<sim> SKIP"
  apply (induct c rule: skip.induct; clarsimp)
  using assign_simp apply auto[1]
  apply fastforce
  apply (metis Chap7_2.IfE big_step.IfFalse big_step.IfTrue)
  by blast+

lemma "x ::= (V x) \<sim> SKIP"
  using assign_simp by auto

lemma "SKIP;; x ::= (V x) \<sim> SKIP"
  using assign_simp by auto

lemma
"let c1 = SKIP in
let c2 = x ::= Plus (V x) (N 1) in
IF (Bc True) THEN c1 ELSE c2 \<sim> SKIP"
  apply clarsimp
  by (metis Chap7_2.IfE big_step.IfTrue bval.simps(1))

lemma "c \<sim> SKIP \<Longrightarrow> skip c"
  apply (induction c)
          apply simp_all
         apply (metis Skip assign_simp fun_upd_idem_iff)
  oops

fun skip' :: "com \<Rightarrow> bool" where
"skip' SKIP = True"
| "skip' (v ::= va) = False"
| "skip' (v;; va) = (skip' v \<and> skip' va)"
| "skip' (IF v THEN va ELSE vb) = (skip' va \<and> skip' vb)"
| "skip' (WHILE v DO va) = False"
| "skip' (REPEAT v UNTIL va) = False"
| "skip' (p OR q) = (skip' p \<and> skip' q)"
| "skip' THROW = False"
| "skip' (TRY p CATCH c) = (skip' p \<and> skip' c)"

lemma "skip' c \<Longrightarrow> c \<sim> SKIP"
  apply (induct c rule: skip'.induct; clarsimp)
     apply fastforce
    apply (metis Chap7_2.IfE big_step.IfFalse big_step.IfTrue)
   apply (metis Chap7_2.ChoiceE big_step.ChoiceRight)
  by blast

fun deskip :: "com \<Rightarrow> com" where
"deskip SKIP = SKIP"
| "deskip (v ::= a) = v ::= a"
| "deskip (SKIP;; p) = deskip p"
| "deskip (p;; SKIP) = deskip p"
| "deskip (p;; q) = (let (p', q') = (deskip p, deskip q) in
if p' = SKIP then q' else if q' = SKIP then p' else p';;q')"
| "deskip (IF b THEN p ELSE q) = IF b THEN deskip p ELSE deskip q"
| "deskip (WHILE b DO p) = WHILE b DO deskip p"
| "deskip (REPEAT p UNTIL b) = REPEAT deskip p UNTIL b"
| "deskip (p OR q) = deskip p OR deskip q"
| "deskip THROW = THROW"
| "deskip (TRY p CATCH c) = TRY (deskip p) CATCH (deskip c)"

lemma "deskip (SKIP ;; WHILE b DO (x ::= a;; SKIP)) = WHILE b DO x ::= a"
  by simp

lemma "deskip ((SKIP;; SKIP);; (SKIP;; SKIP)) = SKIP"
  by simp

lemma skipr[simp]: "(p;;SKIP, s) \<Rightarrow> cs = (p, s) \<Rightarrow> cs"
  by (smt (verit, del_insts) Chap7_2.SeqE Chap7_2.SkipE Seq SeqThrow bs_ref_ss final_iff_SKIP old.prod.exhaust ss_ref_bs star.simps)

lemma skipl[simp]: "(SKIP;;p, s) \<Rightarrow> cs = (p, s) \<Rightarrow> cs"
  by blast

lemma "deskip c \<sim> c"
  apply (induction c rule: deskip.induct; clarsimp)
                      apply (smt (verit, del_insts) Chap7_2.SeqE Seq SeqThrow Skip final_iff_SKIP ss_eq_bs Chap7_2.SkipE)
                      apply blast
                      apply auto[2]
                      apply blast
                      apply blast
                      apply (smt (verit) Chap7_2.SeqE Chap7_2.SkipE Pair_inject Seq SeqThrow Skip com.distinct(13))
                      apply (case_tac "deskip (vb;; vc) = SKIP"; case_tac "deskip (v;; va) = SKIP"; clarsimp)
                      apply (smt (verit) Chap7_2.SeqE Chap7_2.SkipE Seq)
                      apply (smt (verit, ccfv_threshold) Chap7_2.SeqE Chap7_2.SkipE Seq SeqThrow final_iff_SKIP ss_eq_bs star.simps)
                      apply (smt (verit) Chap7_2.SeqE Chap7_2.SkipE Seq Skip com.distinct(13) old.prod.inject)
                      apply blast
                      apply (smt (verit) Chap7_2.SeqE Chap7_2.SkipE Pair_inject Seq SeqThrow Skip com.distinct(13))
                      apply (smt (verit, ccfv_SIG) Chap7_2.SeqE Chap7_2.SkipE Seq SeqThrow Skip com.distinct(13) old.prod.inject)
                      apply (smt (verit, ccfv_SIG) Chap7_2.SeqE Chap7_2.SkipE Pair_inject Seq SeqThrow Skip com.distinct(13))
                      apply (smt (verit, del_insts) Chap7_2.SeqE Seq SeqThrow skipl)
                      apply (smt (verit, best) Chap7_2.SeqE Chap7_2.SkipE Seq SeqThrow Skip prod.inject)
                      apply (case_tac "deskip (v;; va) = SKIP"; clarsimp)
                      apply (smt (verit, best) Chap7_2.SeqE Seq SeqThrow Skip skipl)
                      apply (smt (verit, best) Chap7_2.SeqE Seq SeqThrow Skip skipl)
                      apply blast
                      apply (smt (verit, ccfv_threshold) Chap7_2.SeqE Chap7_2.SkipE Seq SeqThrow Skip bs_ref_ss final_iff_SKIP)
                      apply blast
                      apply (smt (verit, ccfv_SIG) Chap7_2.SeqE Seq SeqThrow)
  using SeqThrow apply (blast+)[4]
                      apply auto[1]
                      apply (smt (verit) Chap7_2.SeqE Chap7_2.SkipE Seq SeqThrow Skip final_iff_SKIP ss_eq_bs)
                      apply (smt (verit, del_insts) Chap7_2.SeqE Seq SeqThrow)
                      apply auto[2]
                      apply (smt (verit) Chap7_2.SeqE Seq SeqThrow)
                      apply auto[1]
                      apply (smt (verit, ccfv_SIG) Chap7_2.SeqE Seq SeqThrow)
                      apply auto[1]
                      apply (smt (verit, ccfv_threshold) Chap7_2.SeqE Chap7_2.SkipE Seq SeqThrow Skip final_iff_SKIP ss_eq_bs)
                      apply blast
                      apply auto[2]
  using SeqThrow apply (blast+)[4]
                      apply (smt (verit, best) Chap7_2.SeqE Chap7_2.SkipE Seq SeqThrow Skip final_iff_SKIP ss_eq_bs)
                      apply blast
                      apply (smt (verit, ccfv_SIG) Chap7_2.SeqE Seq SeqThrow)
  using Seq SeqThrow apply (blast+)[11]
             apply (case_tac "deskip (vb;; vc) = SKIP"; clarsimp)
              apply (smt (verit) Chap7_2.SeqE Seq SeqThrow skipr)
             apply blast
  using SeqThrow apply blast
           apply (smt (verit, best) Chap7_2.SeqE Seq SeqThrow)
  using SeqThrow apply (blast+)[5]
  using sim_while_cong_aux apply fastforce
  using sim_rep_cong_aux apply fastforce
  by blast+

inductive astep :: "aexp * state \<Rightarrow> aexp \<Rightarrow> bool" (infix "\<leadsto>" 50) where
"(V x, s) \<leadsto> N (s x)"
| "(Plus (N i) (N j), s) \<leadsto> N (i + j)"
| "(e, s) \<leadsto> e' \<Longrightarrow> (Plus e e'', s) \<leadsto> Plus e' e''"
| "(e, s) \<leadsto> e' \<Longrightarrow> (Plus (N i) e, s) \<leadsto> Plus (N i) e'"

lemma "(a, s) \<leadsto> a' \<Longrightarrow> aval a s = aval a' s"
  thm astep.induct astep.induct[split_format (complete)]
proof (induction rule: astep.induct[split_format (complete)])
  fix x s
  show "aval (V x) s = aval (N (s x)) s" by simp
next
  fix i j s
  show "aval (Plus (N i) (N j)) s = aval (N (i + j)) s" by simp
next
  fix e s e' e''
  assume "(e, s) \<leadsto> e'" and "aval e s = aval e' s"
  thus "aval (Plus e e'') s = aval (Plus e' e'') s" by simp
next
  fix e s e' i
  assume "(e, s) \<leadsto> e'" and "aval e s = aval e' s"
  thus "aval (Plus (N i) e) s = aval (Plus (N i) e') s" by simp
qed

lemma "IF And b1 b2 THEN c1 ELSE c2 \<sim> IF b1 THEN (IF b2 THEN c1 ELSE c2) ELSE c2"
  apply clarsimp
  subgoal for s t
    apply (cases "bval b1 s")
    by fastforce+
  done

lemma "\<not>WHILE And b1 b2 DO c \<sim> WHILE b1 DO WHILE b2 DO c"
  if "b1 \<equiv> Eq (N 0) (V ''x'')" and "b2 \<equiv> Bc True" and "c \<equiv> ''x'' ::= Plus (V ''x'') (N 1)"
and "s \<equiv> <> :: (char list \<Rightarrow> int)" and "t \<equiv> <''x'' := 1::int>"
  apply clarsimp
  apply (rule exI[where x=s])
  apply (rule exI[where x=SKIP])
  apply (rule exI[where x=t])
  apply (subgoal_tac "(WHILE And b1 b2 DO c, s) \<Rightarrow> (SKIP, t)" "(WHILE b1 DO WHILE b2 DO c, s) \<Rightarrow> (SKIP, t) \<Longrightarrow> False")
  apply blast
   apply (thin_tac "_")
   apply (erule Chap7_2.WhileE)
     apply (thin_tac "_")
     apply (thin_tac "_ \<Rightarrow> (SKIP, t)")
  subgoal for t
    apply (induct "WHILE b2 DO c" s SKIP t rule: big_step_induct)
    unfolding that(2) by auto
  apply simp
   apply (simp add: fun_upd_idem_iff null_state_def that(4) that(5))
  apply (rule WhileTrue[where t=t])
    apply (simp add: null_state_def that(1) that(2) that(4))
  apply (subgoal_tac "t = s(''x'' := aval (Plus (V ''x'') (N 1)) s)")
  using that(3) apply blast
  apply (simp add: null_state_def that(4) that(5))
  apply (rule WhileFalse)
  by (simp add: that(1) that(5))

abbreviation Or where "Or b1 b2 \<equiv> Not (And (Not b1) (Not b2))"

lemma "WHILE Or b1 b2 DO c \<sim> WHILE Or b1 b2 DO c;; WHILE b1 DO c"
  apply clarsimp
  subgoal for s t b
    apply (rule iffI)
     apply (induct "WHILE Or b1 b2 DO c" s t b rule: big_step_induct; clarsimp)
       apply (smt (verit, ccfv_SIG) Chap7_2.SeqE Seq SeqThrow WhileTrue bval.simps(2) bval.simps(3))
      apply (simp add: SeqThrow WhileTrueThrow)
     apply (metis Seq WhileFalse bval.simps(2) bval.simps(3))
    apply (erule Chap7_2.SeqE)
    subgoal for s2
      apply (induct "WHILE Or b1 b2 DO c" s SKIP s2 rule: big_step_induct; clarsimp)
      using WhileTrue bval.simps(2) bval.simps(3) apply presburger
      using WhileFalse by auto
    by simp
  done

definition DoWhile :: "com \<Rightarrow> bexp \<Rightarrow> com" ("(DO _ WHILE _)")where
"DO c WHILE b \<equiv> c ;; WHILE b DO c"

fun dewhile :: "com \<Rightarrow> com" where
"dewhile SKIP = SKIP"
| "dewhile (x ::= a) = x ::= a"
| "dewhile (p ;; q) = dewhile p ;; dewhile q"
| "dewhile (IF b THEN p ELSE q) = IF b THEN (dewhile p) ELSE (dewhile q)"
| "dewhile (WHILE b DO c) = IF (Not b) THEN SKIP ELSE DO (dewhile c) WHILE b"
| "dewhile (REPEAT c UNTIL b) = REPEAT dewhile c UNTIL b"
| "dewhile (p OR q) = dewhile p OR dewhile q"
| "dewhile THROW = THROW"
| "dewhile (TRY p CATCH c) = TRY (dewhile p) CATCH (dewhile c)"

lemma "dewhile c \<sim> c"
  apply (induct c; clarsimp)
       apply blast
      apply blast
  subgoal for b c s r t
    apply (rule iffI)
     apply (erule Chap7_2.IfE)
      apply auto[1]
    unfolding DoWhile_def apply (erule Chap7_2.SeqE)
      apply (simp add: WhileTrue sim_while_cong_aux)
     apply (simp add: WhileTrueThrow)
    apply (erule Chap7_2.WhileE)
      apply (rule Chap7_2.IfFalse)
    using bval.simps(2) apply blast
      apply (simp add: Seq sim_while_cong_aux)
     apply (simp add: SeqThrow big_step.IfFalse)
    by (simp add: Skip big_step.IfTrue)
    apply (simp add: sim_rep_cong)
  by blast+

end


theory Types_to_PERs
  imports String
  (* "HOLRLT-Eisbach.Eisbach" (* Ato D: I hope this is OK *) *)
  keywords
    "wide_typedef" :: thy_goal_defn
begin

(* PRELIMINARIRES *)

(* Copied from Syntax_Independent_Logic.Prelim *)
ML \<open>
exception TAC of term

val simped = Thm.rule_attribute [] (fn context => fn thm =>
  let
    val ctxt = Context.proof_of context;
    val (thm', ctxt') = yield_singleton (apfst snd oo Variable.import false) thm ctxt;
    val full_goal = Thm.prop_of thm';
    val goal = Goal.prove ctxt' [] [] full_goal (fn {context = ctxt, prems = _} =>
      HEADGOAL (asm_full_simp_tac ctxt THEN' TRY o SUBGOAL (fn (goal, _) => raise (TAC goal))))
      |> K (HOLogic.mk_Trueprop @{term True})
      handle TAC goal => goal;
    val thm = Goal.prove ctxt' [] [] goal (fn {context = ctxt, prems = _} =>
      HEADGOAL (Method.insert_tac ctxt [thm'] THEN' asm_full_simp_tac ctxt))
      |> singleton (Variable.export ctxt' ctxt);
  in thm end)

val _ = Theory.setup
  (Attrib.setup \<^binding>\<open>simped\<close> (pair simped) "simped rule");
\<close>

lemma type_definition_inj: "type_definition Rep Abs (Collect t) \<Longrightarrow> inj Rep"
unfolding type_definition_def inj_on_def
	by metis

definition "INV f b = (SOME a. f a = b)"

lemma INV_alt: "INV = inv"
  unfolding INV_def inv_into_def by auto

lemma rel_fun_True: "rel_fun R (=) (\<lambda>_. True) (\<lambda>_. True)"
  by auto

lemma remdups_Cons:
"remdups ys = x # xs \<Longrightarrow>
\<exists>ys1 ys2. ys = ys1 @ x # ys2 \<and>
          (\<forall>i<length ys1. ys1!i \<in> set (drop (Suc i) ys1) \<union> {x} \<union> set ys2) \<and>
          remdups ys2 = xs"
proof(induct ys arbitrary: x xs rule: measure_induct[of length])
  case (1 ys x xs)
  note ih = 1(1)[rule_format]
  show ?case
  proof(cases ys)
  	case Nil
    hence False using 1(2) by auto
  	then show ?thesis by auto
  next
  	case (Cons y' ys') note ys = Cons
  	show ?thesis proof(cases "y' \<in> set ys'")
  		case True
      hence "remdups ys' = x # xs" using 1(2) unfolding ys by auto
      from ih[OF _ this, unfolded ys] obtain ys1 ys2 where 0:
      "ys' = ys1 @ x # ys2 \<and>
      (\<forall>i<length ys1. ys1 ! i \<in> set (drop (Suc i) ys1) \<union> {x} \<union> set ys2) \<and> remdups ys2 = xs" by auto
  		show ?thesis apply(rule exI[of _ "y' # ys1"], rule exI[of _ "ys2"])
      using 0 True unfolding ys using less_Suc_eq_0_disj by auto
  	next
  		case False
      hence r: "y' = x \<and> remdups ys' = xs" using 1(2) unfolding ys by auto
  		show ?thesis apply(rule exI[of _ "[]"], rule exI[of _ "ys'"])
      using r False unfolding ys by auto
  	qed
  qed
qed

lemma remdups_append: "set xs \<subseteq> set ys \<Longrightarrow> remdups (xs @ ys) = remdups ys"
by (induct xs, auto)

lemma remdups_map_inj_on: "inj_on f (set xs) \<Longrightarrow> remdups (map f xs) = map f (remdups xs)"
  by (induct xs) (auto simp: inj_on_def)

(* PERs, NEPERs, etc. *)

type_synonym 'a rel = "'a \<Rightarrow> 'a \<Rightarrow> bool"

definition per :: "'a rel \<Rightarrow> bool" where
  "per r \<equiv> (\<forall>a b. r a b \<longrightarrow> r b a) \<and> (\<forall>a b c. r a b \<and> r b c \<longrightarrow> r a c)"

definition neper :: "'a rel \<Rightarrow> bool" where
  "neper r \<equiv> per r \<and> (\<exists>a. r a a)"

definition perOfPred :: "('a \<Rightarrow> bool) \<Rightarrow> 'a rel" where
  "perOfPred t \<equiv> \<lambda>a a'. a = a' \<and> t a"

lemma per_perOfPred: "per (perOfPred t)"
  unfolding per_def perOfPred_def by auto

lemma per_rel_fun: "per Rsigma \<Longrightarrow> per Rtau \<Longrightarrow> per (rel_fun Rsigma Rtau)"
  unfolding rel_fun_def per_def by meson

lemma ex_rel_fun: "Rtau y y \<Longrightarrow> \<exists>f. rel_fun Rsigma Rtau f f"
  apply(intro exI[of _ "\<lambda>_ . y"])
  unfolding rel_fun_def by auto

named_theorems neper
named_theorems rrel_eq
named_theorems rrel_alt
named_theorems bij_upto
named_theorems rlt_eq
named_theorems rlt_param
named_theorems rep_eq
named_theorems cond_eq
named_theorems quasidef

lemma neper_rel_fun[neper]: "neper Rsigma \<Longrightarrow> neper Rtau \<Longrightarrow> neper (rel_fun Rsigma Rtau)"
  by (metis ex_rel_fun neper_def per_rel_fun)

declare fun.rel_eq[simp,intro!,rrel_eq]

(* Sometimes more intuitive to build PERs from sets:  *)
definition perOfSet :: "'a set \<Rightarrow> 'a rel" where
  "perOfSet A \<equiv> \<lambda>a a'. a = a' \<and> a \<in> A"

lemma per_perOfSet: "per (perOfSet A)"
  unfolding per_def perOfSet_def by auto

definition restr :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
  "restr R P x y = (R x y \<and> P x \<and> P y)"

lemma per_restr: "per R \<Longrightarrow> per (restr R A)"
  unfolding per_def restr_def by blast

lemma restr_eq: "restr (=) = eq_onp"
  unfolding restr_def eq_onp_def by auto

lemma neper_restr: "neper R \<Longrightarrow> (\<exists>x. A x \<and> R x x) \<Longrightarrow> neper (restr R A)"
  by (metis neper_def per_restr restr_def)

lemma per_eq[simp,intro!]: "per (=)" unfolding per_def by auto
lemma neper_eq[simp,intro!,neper]: "neper (=)"
  by (simp add: neper_def per_def)

lemma neper_per[simp]: "neper R \<Longrightarrow> per R"
  unfolding neper_def by blast

lemma neper_eq_onp[simp]: "\<exists>x. P x \<Longrightarrow> neper (eq_onp P)"
unfolding neper_def per_def eq_onp_def by auto

lemma restr_leq: "restr R P \<le> restr R Q \<Longrightarrow> restr (restr R P) Q = restr R P"
unfolding restr_def by auto

(* More reusable infrastructure for NEPERs *)

definition getRepr :: "'a rel \<Rightarrow> 'a \<Rightarrow> 'a" where
  "getRepr R a \<equiv> SOME a'. a' \<in> {a' . R a a'}"

lemma getRepr_neper:
"neper R \<Longrightarrow> R a a \<Longrightarrow> R a (getRepr R a)"
	by (simp add: getRepr_def tfl_some)

lemma getRepr_eq[simp]: "getRepr (=) = id"
  unfolding getRepr_def by auto

lemma neper_classes_eq: "neper R \<Longrightarrow> R a b \<Longrightarrow> {a'. R a a'} = {a'. R b a'}"
	by (metis neper_per per_def)

lemma neper_getRepr_eq: "neper R \<Longrightarrow> R a b \<Longrightarrow> getRepr R a = getRepr R b"
unfolding getRepr_def  by (simp add: neper_classes_eq)

lemma getRepr_inject:
"neper R \<Longrightarrow> R a a \<Longrightarrow> R b b \<Longrightarrow> R (getRepr R a) (getRepr R b) \<Longrightarrow> getRepr R a = getRepr R b"
	by (metis getRepr_neper neper_getRepr_eq)

lemma geterRepr_related: "neper R \<Longrightarrow> R a a \<Longrightarrow> R (getRepr R a) a"
	by (metis getRepr_neper neper_per per_def)

lemma per_inv_imagep: "per R \<Longrightarrow> per (inv_imagep R f)"
  unfolding neper_def per_def inv_imagep_def by blast

lemma neper_inv_imagep: "neper R \<Longrightarrow> R (f a) (f a) \<Longrightarrow> neper (inv_imagep R f)"
  unfolding neper_def per_def inv_imagep_def by blast

lemma rel_set_getRepr:
"neper R \<Longrightarrow> rel_set R A B \<Longrightarrow> {getRepr R a | a.  a \<in> A} = {getRepr R a | a.  a \<in> B}"
unfolding rel_set_def
apply auto by (metis neper_getRepr_eq)+

lemma rel_fun_getRepr_eq:
"neper R \<Longrightarrow> rel_fun R (=) (f \<circ> getRepr R) (f \<circ> getRepr R)"
unfolding rel_fun_def by (simp add: neper_getRepr_eq)

lemma ne_getRepr: "neper R \<Longrightarrow> {getRepr R a |a. R a a} \<noteq> {}"
apply auto using neper_def by blast

lemma neper_rel_set_domain[simp]: "neper R \<Longrightarrow> rel_set R {x. R x x} {x. R x x}"
unfolding rel_set_def using neper_classes_eq by fastforce

lemma ne_rel_set: "\<exists>x. rel_set R x x"
  unfolding rel_set_def by auto

lemma per_rel_set: "per R \<Longrightarrow> per (rel_set R)"
  unfolding per_def rel_set_def by meson

lemma neper_rel_set: "per R \<Longrightarrow> neper (rel_set R)"
  by (simp add: ne_rel_set neper_def per_rel_set)

declare neper_rel_set[simp] neper_rel_fun[simp]

declare rel_set_eq[simp,intro!]

lemma neper_Some: "neper R \<Longrightarrow> R (SOME x. R x x) (SOME x. R x x)"
by (meson neper_def someI_ex)

(* A slightly better behaved getRepr, which avoids bad behavior outside the
relation's domain *)
definition "getRepr' R \<equiv> \<lambda>a. if R a a then getRepr R a else (SOME a'. R a' a')"

lemma inRel_getRepr': "neper R \<Longrightarrow> R x y \<Longrightarrow> R (getRepr' R x) (getRepr' R y)"
by (metis (no_types, lifting) getRepr'_def geterRepr_related neper_per per_def)

lemma getRepr'_iff_inRel: "neper R \<Longrightarrow> R x x \<Longrightarrow> R y y \<Longrightarrow> R (getRepr' R x) (getRepr' R y) \<longleftrightarrow> R x y"
	by (metis (mono_tags, lifting) getRepr'_def getRepr_neper mem_Collect_eq neper_classes_eq)

(* Picking equiv-classes representatives from a preferred set, if possible: *)
definition "getReprOn A R \<equiv>
  \<lambda>a. if (\<exists>b. b \<in> A \<and> R a b) then (SOME b. b \<in> A \<and> R a b) else getRepr R a"

lemma getReprOn_in:
"neper R \<Longrightarrow> b \<in> A \<Longrightarrow> R a b \<Longrightarrow> getReprOn A R a \<in> A \<and> R a (getReprOn A R a)"
by (metis (no_types, lifting) getReprOn_def someI_ex)

lemma getReprOn_in':
"neper R \<Longrightarrow> \<exists>b \<in> A. R a b \<Longrightarrow> getReprOn A R a \<in> A \<and> R a (getReprOn A R a)"
by (metis (no_types, lifting) getReprOn_def someI_ex)

lemma getReprOn:
"neper R \<Longrightarrow> R a b \<Longrightarrow> R a (getReprOn A R a)"
by (metis (mono_tags, lifting) CollectD CollectI getReprOn_def
     getReprOn_in getRepr_neper neper_classes_eq neper_getRepr_eq)

lemma getReprOn_eq[simp]: "a \<in> A \<Longrightarrow> getReprOn A (=) a = a"
  unfolding getReprOn_def by (simp add: some_equality)

lemma neper_getReprOn_eq:
"neper R \<Longrightarrow> a \<in> A \<Longrightarrow> b \<in> A \<Longrightarrow> R a b \<Longrightarrow> getReprOn A R a = getReprOn A R b"
  unfolding getReprOn_def using neper_classes_eq[of R a b]
  by (auto intro!: Eps_cong)

lemma neper_getReprOn_eq_strong:
"neper R \<Longrightarrow> R a b \<Longrightarrow> getReprOn A R a = getReprOn A R b"
  unfolding getReprOn_def using neper_classes_eq[of R] neper_getRepr_eq[of R]
  by (intro if_cong Eps_cong) fastforce+

lemma neper_trans: "neper R \<Longrightarrow> R a b \<Longrightarrow> R b c \<Longrightarrow> R a c"
  unfolding neper_def per_def by blast

lemma neper_sym: "neper R \<Longrightarrow> R a b \<Longrightarrow> R b a"
  unfolding neper_def per_def by blast

lemma getReprOn_inject:
"neper R \<Longrightarrow> a' \<in> A \<Longrightarrow> b' \<in> A \<Longrightarrow> R a a' \<Longrightarrow> R b b' \<Longrightarrow>
 R (getReprOn A R a) (getReprOn A R b) \<Longrightarrow> getReprOn A R a = getReprOn A R b"
  using neper_classes_eq[of R a b, OF _ neper_trans[of R, OF _ getReprOn[of R _ a' A] neper_sym[of R,
    OF _ neper_trans[of R, OF _ getReprOn[of R _ b' A] neper_sym[of R]]]]]
  by (auto simp: getReprOn_def intro: Eps_cong)

lemma geterReprOn_related:
"neper R \<Longrightarrow> a' \<in> A \<Longrightarrow> R a a' \<Longrightarrow> R (getReprOn A R a) a"
by (metis getReprOn_in neper_def per_def)

lemma getReprOn_UNIV: "neper R \<Longrightarrow> getReprOn UNIV R = getRepr R"
unfolding getReprOn_def getRepr_def by auto

lemma rel_fun_getReprOn_eq:
  assumes "neper R"
  shows "rel_fun R (=) (f \<circ> getReprOn A R) (f \<circ> getReprOn A R)"
  by (auto simp: rel_fun_def dest: neper_getReprOn_eq_strong[OF assms, of _ _ A])

(* *)

definition closed where "closed R A \<equiv> \<forall>a\<in>A. \<forall>b. R a b \<longrightarrow> b\<in>A"

lemma closed_emp[simp,intro!]: "closed R {}"
unfolding closed_def by auto

lemma closed_Un: "closed R A \<Longrightarrow> closed R B \<Longrightarrow> closed R (A \<union> B)"
unfolding closed_def by auto

definition closure :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a set \<Rightarrow> 'a set" where
"closure R A \<equiv> {x. \<exists>a. a \<in> A \<and> R a x}"

lemma closure_empty[simp]: "closure R {} = {}"
unfolding closure_def by auto

lemma closed_iff_eq_closure: "rel_set R A A \<Longrightarrow> closed R A \<longleftrightarrow> closure R A = A"
unfolding closed_def closure_def by auto (meson rel_setD2)

lemma closure_Un: "closure R (A \<union> B) = closure R A \<union> closure R B"
unfolding closure_def by auto

lemma closure_ext: "rel_set R A A \<Longrightarrow> A \<subseteq> closure R A"
unfolding rel_set_def closure_def by auto

lemma closure_idem[simp]: "neper R \<Longrightarrow> closure R (closure R A) = closure R A"
unfolding rel_set_def closure_def using neper_classes_eq by fastforce

lemma closure_idem_Un[simp]:
"neper R \<Longrightarrow> closure R (closure R {a} \<union> closure R A) = closure R {a} \<union> closure R A"
by (simp add: closure_Un)

lemma rel_set_closure: "rel_set R A A \<Longrightarrow> rel_set R A (closure R A)"
unfolding rel_set_def closure_def by blast

lemma rel_set_imp_closure: "neper R \<Longrightarrow> rel_set R A B \<Longrightarrow> rel_set R (closure R A) (closure R B)"
unfolding rel_set_def closure_def
by simp (metis neper_def per_def)

lemma rel_set_closure_iff[simp]:
"neper R \<Longrightarrow> rel_set R A A \<Longrightarrow> rel_set R B B \<Longrightarrow>
 rel_set R (closure R A) (closure R B) \<longleftrightarrow> rel_set R A B"
  by (metis neper_per per_def per_rel_set rel_set_closure)

lemma closed_closure[simp]: "neper R \<Longrightarrow> rel_set R A A \<Longrightarrow> closed R (closure R A)"
  by (auto simp: closed_iff_eq_closure)

lemma rel_set_getRepr_closure:
"neper R \<Longrightarrow> rel_set R A A \<Longrightarrow> {getRepr R a |a. a \<in> closure R A} = {getRepr R a |a. a \<in> A}"
using rel_set_closure rel_set_getRepr by blast

lemma neper_closed_domain[simp]: "neper R \<Longrightarrow> closed R {x. R x x}"
unfolding closed_def using neper_classes_eq by fastforce

lemma rel_set_closure': "neper R \<Longrightarrow> rel_set R (closure R A) (closure R A)"
unfolding rel_set_def closure_def apply simp
	by (metis CollectD CollectI neper_classes_eq)

lemma rel_set_closure_eq: "neper R \<Longrightarrow> rel_set R A B \<Longrightarrow> closure R A = closure R B"
unfolding rel_set_def closure_def
	using neper_classes_eq by fastforce

lemma eq_closure_iff: "neper R \<Longrightarrow> R a a \<Longrightarrow> R b b \<Longrightarrow> closure R {a} = closure R {b} \<longleftrightarrow> R a b"
unfolding closure_def apply auto
	using neper_classes_eq by fastforce+

lemma rel_set_closure_iff':
"neper R \<Longrightarrow> R a a \<Longrightarrow> R b b \<Longrightarrow> rel_set R (closure R {a}) (closure R {b}) \<longleftrightarrow> R a b"
unfolding closure_def by (auto simp: rel_set_def dest: neper_sym neper_trans)

lemma rel_set_closure_rel_conj:
assumes Q: "neper (rel_conj R Q)" and R: "neper R" and r: "rel_conj R Q a a" "rel_conj R Q b b"
and rc: "rel_set R (closure (rel_conj R Q) {a}) (closure (rel_conj R Q) {b})"
shows "rel_conj R Q a b"
using assms
  unfolding closure_def rel_set_def OO_def apply (auto)
  by (meson neper_trans)

lemma closure_relcompp2:
"neper Q \<Longrightarrow> neper (restr R (\<lambda>i. Q i i)) \<Longrightarrow> closure (rel_conj Q R) (closure Q A) = closure (Q OO R OO Q) A"
  unfolding closure_def restr_def apply auto
  using neper_trans apply fastforce
	using neper_classes_eq apply fastforce
  done

lemma closure_singl: "neper R \<Longrightarrow> closure R {xa} = {x. R x xa}"
unfolding closure_def
by simp (metis CollectD CollectI geterReprOn_related neper_classes_eq)+

lemma quotient_closure: "quotient A {(x, y). Q x y} = {closure Q {a} | a . a \<in> A}"
unfolding quotient_def closure_def by auto

(* *)

(**************)
(* Used to show that relators preserve neper's: *)

lemma neper_conversep: "neper R \<Longrightarrow> R = conversep R"
	by (metis neper_def per_def symp_conv_conversep_eq symp_def)

lemma neper_relcompp_leq: "neper R \<Longrightarrow> R OO R = R"
  apply (rule antisym)
  apply(metis neper_per per_def transp_def transp_relcompp_less_eq)
	by (metis (mono_tags, lifting) OO_def mem_Collect_eq neper_classes_eq predicate2I)

lemma closure_relcompp: "neper R \<Longrightarrow> neper Q \<Longrightarrow> closure (Q OO R) (closure Q A) = closure (Q OO R) A"
unfolding closure_def apply auto
	apply (metis neper_relcompp_leq relcomppI)
  by (metis mem_Collect_eq neper_classes_eq relcompp.simps)

lemma relator_pres_neper:
assumes cm: "\<And>R1 R2. G (R1 OO R2) = G R1 OO G R2"
and cv: "\<And>R. G (conversep R) = conversep (G R)"
and ne: "\<exists>x. G R x x"
and R: "neper R"
shows "neper (G R)"
  using cm[of R R] cv[of R] ne R neper_relcompp_leq[OF R]
  unfolding neper_def per_def conversep_iff relcompp_apply
  by (metis (full_types) R conversep_iff cv neper_conversep)

(* BIJECTIONS UP-TO *)

definition bij_upto :: "'a rel \<Rightarrow> 'b rel \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool" where
  "bij_upto P Q f \<equiv>
   ((\<forall>x x'. P x x' \<longrightarrow> Q (f x) (f x')) \<and>
    (\<forall>x x'. P x x \<and> P x' x' \<longrightarrow> Q (f x) (f x') \<longrightarrow> P x x') \<and>
    (\<forall>y. Q y y \<longleftrightarrow> (\<exists>x. P x x \<and> Q y (f x))))"

(* *)
(* Compared with unfolding the definition, this
avoids rechecking a redundan bit in the last conjunct *)
lemma bij_uptoI:
assumes "neper Q"
and "\<And>x x'. P x x' \<Longrightarrow> Q (f x) (f x')"
and "\<And>x x'. P x x \<Longrightarrow> P x' x' \<Longrightarrow> Q (f x) (f x') \<Longrightarrow> P x x'"
and "\<And>y. Q y y \<Longrightarrow> \<exists>x. P x x \<and> Q y (f x)"
shows "bij_upto P Q f"
using assms unfolding bij_upto_def by (meson neper_per per_def)

lemma bij_upto_id: "neper P \<Longrightarrow> bij_upto P P id"
apply(rule bij_uptoI) by auto

lemma bij_upto_id': "neper P \<Longrightarrow> P = Q \<Longrightarrow> bij_upto P Q id" using bij_upto_id by auto

lemma bij_upto_rel_fun: "bij_upto P Q f \<Longrightarrow> rel_fun P Q f f"
  unfolding bij_upto_def rel_fun_def by blast

lemma bij_upto_rel_fun': "bij_upto P Q f \<Longrightarrow> Q \<le> Q' \<Longrightarrow> rel_fun P Q' f f"
  unfolding bij_upto_def rel_fun_def by blast

lemma type_copy_bij: "type_definition f g UNIV \<Longrightarrow> bij f"
  by (meson o_bij type_copy_Abs_o_Rep type_copy_Rep_o_Abs)

lemma neper_vimage2p_bij: "bij f \<Longrightarrow> neper R \<Longrightarrow> neper (vimage2p f f R)"
  unfolding neper_def per_def vimage2p_def bij_iff
  by metis

lemma vimage2p_bij_eq: "bij f \<Longrightarrow> R = (=) \<Longrightarrow> vimage2p f f R = (=)"
  unfolding neper_def per_def vimage2p_def bij_iff
  by blast

lemma restr_self: "neper R \<Longrightarrow> restr R (\<lambda>x. \<exists>a. R a a \<and> R a x) = R"
  unfolding restr_def fun_eq_iff neper_def per_def
  by metis

lemma restr_True: "neper R \<Longrightarrow> restr R (\<lambda>x. True) = R"
  unfolding restr_def fun_eq_iff neper_def per_def
  by metis

lemma bij_upto_bij: "bij f \<Longrightarrow> neper R \<Longrightarrow> bij_upto (vimage2p f f R) R f"
  unfolding bij_upto_def vimage2p_def bij_iff neper_def per_def id_apply
  by metis

lemma bij_upto_iff_bij_betw:
"bij_upto (perOfSet A) (perOfSet B) f \<longleftrightarrow> bij_betw f A B"
unfolding bij_upto_def bij_betw_def inj_on_def perOfSet_def by auto

lemma type_definition_bij_upto:
  assumes "type_definition Rep Abs (Collect A)"
  shows "bij_upto (=) (eq_onp A) Rep"
  by (auto simp: bij_upto_def eq_onp_def
    type_definition.Rep[OF assms, simplified]
    type_definition.Rep_inject[OF assms, simplified]
    elim: type_definition.Rep_cases[OF assms, simplified])

(* General-purpose infrastructure for generating "default" relators for new types *)

lemma bij_upto_restr_inv_imagep:
assumes "neper Q" and "\<And>x. t x \<Longrightarrow> tr (f x) \<and> Q (f x) (f x)"
and "\<And>y. tr y \<and> Q y y \<Longrightarrow> \<exists>x. t x \<and> Q y (f x)"
shows "bij_upto (restr (inv_imagep (restr Q tr) f) t) (restr Q tr) f"
using assms unfolding bij_upto_def restr_def
  by simp (metis neper_per per_def)

lemma bij_upto_inv_imagep:
assumes "{x. R x x} \<subseteq> range Rep" and "bij_upto R Q f"
shows "bij_upto (inv_imagep R Rep) Q (f o Rep)"
  using assms unfolding bij_upto_def inv_imagep_def image_def apply safe
  subgoal by (metis comp_eq_dest_lhs)
  subgoal by (metis comp_eq_dest_lhs)
  subgoal for y
    apply (drule spec[of _ y])
    apply (drule iffD1, assumption)
    apply (erule exE conjE)+
    apply (drule subsetD)
     apply (erule CollectI)
    apply (erule CollectE bexE)+
    apply hypsubst_thin
    by (metis comp_eq_dest_lhs)
  subgoal by (metis comp_eq_dest_lhs) .

lemma bij_upto_restr_inv_imagep_inj:
assumes c: "Collect t \<subseteq> range Rep"
and "neper Q" "\<And>x. t x \<Longrightarrow> tr (f x) \<and> Q (f x) (f x)"
and "\<And>y. tr y \<and> Q y y \<Longrightarrow> \<exists>x. t x \<and> Q y (f x)"
shows
"bij_upto
   (inv_imagep (restr (inv_imagep (restr Q tr) f) t) Rep)
   (restr Q tr)
   (f \<circ> Rep)"
apply(rule bij_upto_inv_imagep
  [OF _ bij_upto_restr_inv_imagep[OF assms(2-4), simplified]])
using c unfolding restr_def inv_imagep_def by auto

(* can be used for many wide_typedefs (namely those whose types
do not have well-behaved relators), to simplify bureaucracy: *)
lemma bij_upto_criterion:
assumes c: "type_definition Rep Abs (Collect t)"
and "neper Q" "\<And>x. t x \<Longrightarrow> tr (f x) \<and> Q (f x) (f x)"
and "\<And>y. tr y \<and> Q y y \<Longrightarrow> \<exists>x. t x \<and> Q y (f x)"
shows
"bij_upto
   (inv_imagep (restr (inv_imagep (restr Q tr) f) t) Rep)
   (restr Q tr)
   (f \<circ> Rep)"
apply(rule bij_upto_restr_inv_imagep_inj[OF _ assms(2-4)])
using c unfolding type_definition_def image_def by auto metis

lemma neper_criterion:
"type_definition Rep Abs (Collect t) \<Longrightarrow> neper Q \<Longrightarrow> \<exists>x. t x \<Longrightarrow>
(\<And>x. t x \<Longrightarrow> tr (f x) \<and> Q (f x) (f x)) \<Longrightarrow>
neper (inv_imagep (restr (inv_imagep (restr Q tr) f) t) Rep)"
apply safe
subgoal for x
apply(rule neper_inv_imagep)
  subgoal apply(rule neper_restr)
    subgoal apply(rule neper_inv_imagep[of _ _ x])
      subgoal apply(rule neper_restr)
        subgoal by simp
        subgoal by auto .
    subgoal unfolding restr_def by auto .
  subgoal apply(rule exI[of _ x])
  unfolding inv_imagep_def restr_def by auto .
  by (simp add: restr_def type_definition_def) .

lemma eq_criterion:
"type_definition Rep Abs (Collect t) \<Longrightarrow>  (\<And>x. t x \<Longrightarrow> tr x) \<Longrightarrow>
 inv_imagep (restr (inv_imagep (restr (=) tr) id) t) Rep = (=)"
unfolding inv_imagep_def restr_def fun_eq_iff apply auto
	apply (auto simp add: inj_eq type_definition.Rep_inject)
	by (meson mem_Collect_eq type_definition.Rep)+

(* The next theorem should be used when we think of the wide-typedef construction on the
raw type first, and not on the defined type directly
(which is recommended in most cases, to avoid confusion when reasoning about the bijection-up-to)
*)
lemma bij_upto_transportFromRaw:
assumes t: "type_definition Rep Abs (Collect t)" and P': "P' = inv_imagep P Rep"
and b: "bij_upto (restr P t) Q f"
shows "bij_upto P' Q (f o Rep)"
proof-
  have P': "P' = inv_imagep (restr P t) Rep"
  using t unfolding P' restr_def inv_imagep_def fun_eq_iff
  by (simp add: type_definition_def)
  show ?thesis unfolding P' apply(rule bij_upto_inv_imagep)
  using b t  by auto (metis CollectI restr_def t type_definition.Rep_range)
qed

(* INVERSES UPTO *)

definition "inv_upto R1 R2 f i2 \<equiv> SOME i1. R1 i1 i1 \<and> R2 i2 (f i1)"

lemma inv_upto: "bij_upto R1 R2 f \<Longrightarrow> R2 i2 i2 \<Longrightarrow>
   R1 (inv_upto R1 R2 f i2) (inv_upto R1 R2 f i2) \<and> R2 i2 (f ((inv_upto R1 R2 f i2)))"
unfolding inv_upto_def apply(rule someI_ex[of "\<lambda>i1. R1 i1 i1 \<and> R2 i2 (f i1)"])
unfolding bij_upto_def by blast

lemmas inv_upto_forth = inv_upto[THEN conjunct1]
lemmas inv_upto_back = inv_upto[THEN conjunct2]

lemma inv_upto_bij_upto:
assumes R1: "neper R1" and R2: "neper R2" and b: "bij_upto R1 R2 f"
defines "g \<equiv> inv_upto R1 R2 f"
shows "bij_upto R2 R1 g"
proof-
  have g: "\<And>i2. R2 i2 i2 \<Longrightarrow> R1 (g i2) (g i2)"
       "\<And>i2. R2 i2 i2 \<Longrightarrow> R2 i2 (f (g i2))"
  	by (auto simp add: b g_def inv_upto)
  show ?thesis
  apply(rule bij_uptoI[OF R1])
    subgoal for x y using b unfolding bij_upto_def
      by (metis (full_types) CollectD CollectI R2 g(1) g(2) neper_classes_eq)
     subgoal using b unfolding bij_upto_def
     	 by (metis (full_types) R2 g(2) mem_Collect_eq neper_classes_eq)
     subgoal using b unfolding bij_upto_def
     	 by (meson g(1) g(2)) .
qed

lemma bij_upto_eq_bij: "bij_upto (=) (=) f \<longleftrightarrow> bij f"
unfolding bij_upto_def bij_def inj_def surj_def by auto

lemma inv_upto_eq_inv: "bij f \<longrightarrow> inv_upto (=) (=) f = inv f"
	by (metis (mono_tags) bij_def bij_upto_eq_bij inj_imp_inv_eq inv_upto)

lemma inv_upto_iff_bij_betw:
"bij_betw f A B \<Longrightarrow> inv_upto (perOfSet A) (perOfSet B) f = inv_into A f"
  unfolding bij_betw_def inj_on_def perOfSet_def inv_upto_def inv_into_def fun_eq_iff
  by auto (metis image_eqI)

lemma inv_upto_eqI:
assumes R: "R1 = perOfSet A" "R2 = perOfSet A"
and f: "\<forall>a\<in>A. f a = a" "bij_betw f A A"
 and a: "a \<in> A"
shows "inv_upto R1 R2 f a = a"
proof-
  have 0: "R1 a a" using R a unfolding perOfSet_def by auto
  show ?thesis unfolding R
  using inv_upto[OF f(2)[unfolded bij_upto_iff_bij_betw[symmetric] R[symmetric]] 0]
  unfolding R perOfSet_def apply auto
  unfolding perOfSet_def[symmetric] using f(2)
  unfolding inv_upto_iff_bij_betw[OF f(2)]
  by (simp add: f(1))
qed

(* RELATIVIZATION OF CHOICE *)

(* The correct version of choice relativisation: *)
definition Eps_rlt :: "'a rel \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a" where
  "Eps_rlt \<equiv> \<lambda>R. \<lambda>p. if (\<exists>x. R x x \<and> p x)
  then (SOME x. R x x \<and> p x)
  else (SOME x. R x x \<and> R \<noteq> (=))"

(* Sanity checks for Eps_rlt: *)

(* 1. Sanity check: proving by hand the relativized version of
the characteristic theorem: *)
thm someI[no_vars]

lemma someI_rlt: "rel_fun R (=) P P \<Longrightarrow> R x x \<Longrightarrow> P x \<Longrightarrow> P (Eps_rlt R P)"
  unfolding Eps_rlt_def rel_fun_def
  by (subst if_P) (blast | rule someI2_ex)+

(* 2. NEPER-parametricity: *)

lemma neper_param_Eps_rlt:
  assumes "neper R"
  shows "rel_fun (rel_fun R (=)) R (Eps_rlt R) (Eps_rlt R)"
  unfolding rel_fun_def Eps_rlt_def apply auto
  subgoal for f x g y
    apply (subgoal_tac "(SOME x. R x x \<and> f x) = (SOME x. R x x \<and> g x)")
     apply (metis (no_types, lifting) tfl_some)
    apply (rule Eps_cong; blast)
    done
  by (metis (mono_tags, lifting) assms neper_def someI_ex)

(* 3. Recoverability: *)

lemma Eps_rlt_eq[symmetric, rlt_eq]: "Eps = Eps_rlt (=)"
  unfolding Eps_rlt_def
  apply (rule ext)
  subgoal for p
    apply (cases "\<exists>x. x = x \<and> p x")
    subgoal by auto
    subgoal
      apply auto
      by presburger . .

lemma Eps_rlt_True: "neper R \<Longrightarrow> Eps_rlt R (\<lambda>_. True) = (SOME a. R a a)"
unfolding Eps_rlt_def by presburger

(* Relativizing indefinitite choice: *)

definition The_rlt :: "'a rel \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> 'a" where
  "The_rlt \<equiv> \<lambda>R. \<lambda>p. if (\<exists>x. R x x \<and> p x) \<and>
                        (\<forall>x y. R x x \<and> R y y \<and> p x \<and> p y \<longrightarrow> R x y)
  then (SOME x. R x x \<and> p x)
  else if R = (=) then (THE x. p x)
  else (SOME x. R x x)"

(* 1. Sanity check: proving by hand the relativized version of
the characteristic theorems: *)
thm theI[no_vars]

lemma "neper R \<Longrightarrow> rel_fun R (=) P P \<Longrightarrow> R x x \<Longrightarrow>
 P x \<Longrightarrow> (\<And>y. P y \<Longrightarrow> R y x) \<Longrightarrow> P (The_rlt R P)"
  unfolding The_rlt_def rel_fun_def
  apply (subst if_P)
   apply (metis neper_sym neper_trans)
  apply (rule someI2_ex)
   apply blast
  apply blast
  done

thm theI_unique[no_vars]

lemma "neper R \<Longrightarrow> rel_fun R (=) P P \<Longrightarrow> R x x \<Longrightarrow>
 (\<And>y. P y \<Longrightarrow> R y x) \<Longrightarrow> P x \<longleftrightarrow> P (The_rlt R P)"
  unfolding The_rlt_def rel_fun_def
  apply (rule iffI)
   apply (subst if_P)
    apply (metis neper_sym neper_trans)
   apply (rule someI2_ex)
    apply blast
   apply blast
  apply blast
  done

(* Parametricity: *)
lemma neper_param_The_rlt:
  assumes "neper (R::'a rel)"
  shows "rel_fun (rel_fun R (=)) R (The_rlt R) (The_rlt R)"
unfolding rel_fun_def proof safe
  fix p q::"'a\<Rightarrow>bool" assume 0: "\<forall>x y. R x y \<longrightarrow> p x = q y"
  show "R (The_rlt R p) (The_rlt R q)"
  proof(cases "(\<exists>x. R x x \<and> p x) \<and>
               (\<forall>x y. R x x \<and> R y y \<and> p x \<and> p y \<longrightarrow> R x y)")
    case True
    have *: "(SOME x. R x x \<and> p x) = (SOME x. R x x \<and> q x)"
      by (rule Eps_cong) (auto simp: 0)
    have "R (SOME x. R x x \<and> p x) (SOME x. R x x \<and> q x)"
      unfolding *[symmetric] by (rule someI2_ex) (use True in \<open>blast\<close>)+
    thus ?thesis
      using True unfolding The_rlt_def if_P[OF True] using 0
      by (subst if_P) blast
  next
    case False note f = False
    show ?thesis
    proof(cases "R = (=)")
      case True thus ?thesis
      	using "0" by presburger
    next
      case False
      have "R (SOME x. R x x) (SOME x. R x x)"
      by (meson assms neper_def some_eq_imp)
    thus ?thesis unfolding The_rlt_def if_not_P[OF f] if_not_P[OF False]
      using 0 f by (subst if_not_P) blast
    qed
  qed
qed

(* 3. Recoverability: *)
lemma The_rlt_eq[symmetric, rlt_eq]: "The = The_rlt (=)"
  unfolding The_rlt_def
  apply (rule ext)
  subgoal for p
  apply (cases "(\<exists>x. x = x \<and> p x) \<and> (\<forall>x y. x = x \<and> y = y \<and> p x \<and> p y \<longrightarrow> x = y)")
    subgoal by (auto simp: someI the_equality)
    subgoal by auto . .

(* UNIFORM INFRASTRUCTURE FOR TYPEDEFS *)

definition rep :: "('old \<Rightarrow> bool) \<Rightarrow> 'new \<Rightarrow> 'old" where
  "rep t \<equiv> SOME Rep. (\<forall>y. t y \<longleftrightarrow> (\<exists>x. y = Rep x)) \<and>
                         (\<forall>x y. Rep x = Rep y \<longrightarrow> x = y)"

lemma sanityCheck_abs_rep:
  fixes Rep :: "'new \<Rightarrow> 'old"
  assumes "type_definition Rep Abs (Collect t)"
  shows "type_definition (rep t ::'new \<Rightarrow> 'old) (INV (rep t)) (Collect t)" (is "type_definition ?r _ _")
proof-
  have 1: "(\<forall>y. t y \<longleftrightarrow> (\<exists>x. y = Rep x)) \<and> (\<forall>x y. Rep x = Rep y \<longrightarrow> x = y)"
    using assms unfolding type_definition_def by simp metis
  have 11: "(\<forall>y. t y \<longleftrightarrow> (\<exists>x. y = ?r x)) \<and> (\<forall>x y. ?r x = ?r y \<longrightarrow> x = y)"
    unfolding rep_def
    by (rule someI[of "\<lambda>Rep. (\<forall>y. t y \<longleftrightarrow> (\<exists>x. y = Rep x)) \<and> (\<forall>x y. Rep x = Rep y \<longrightarrow> x = y)"])
      (auto simp: 1)
  moreover
  have 2: "\<forall>a\<in>Collect t. \<exists>b. ?r b = a" using 11 by auto
  then obtain Aabs where 22: "\<forall>a\<in>Collect t. ?r (Aabs a) = a" by metis
  { fix a assume a: "a\<in>Collect t"
    have "?r (INV ?r a) = a" unfolding INV_def
      by(rule someI[of "\<lambda>b. rep t b = a" "Aabs a"]) (auto simp: bspec[OF 22 a])
  }
  ultimately show ?thesis unfolding type_definition_def by auto
qed

axiomatization where TYPE_singleton: "\<And>x y :: 'a::{} itself. x \<equiv> y"

definition Rep_itself where "Rep_itself (TYPE('a)) = ()"
definition Abs_itself where "Abs_itself (x :: unit) = (TYPE('a))"
lemma type_definition_itself:
  "type_definition Rep_itself Abs_itself {x. True}"
  by standard (auto simp: Abs_itself_def TYPE_singleton)

lemma itself_abs_def:
  assumes "f TYPE('a) \<equiv> (x :: 'b :: {})"
  shows "f \<equiv> (\<lambda>_::'a :: {} itself. x)"
proof -
  from assms have "f i \<equiv> x" for i
    using TYPE_singleton[of "TYPE('a)" i] by simp
  from this[abs_def] show "f \<equiv> (\<lambda>_::'a :: {} itself. x)"
    .
qed

(*NOTE: make sure that there are no typedecls along dependencies*)

ML_file "../Tools/wide_database.ML"
ML_file "../Tools/relativization.ML"
ML_file "../Tools/wide_typedef.ML"
ML_file "../Tools/wide_datatype.ML"

ML \<open>fun RLCST t lthy = Relativization.RLTHM
  (t |> dest_Const |> fst |> Binding.qualified_name |> Binding.prefix_name "refl_" |> Binding.suffix_name "_rlt")
  (infer_instantiate' lthy [SOME (Thm.cterm_of lthy t)] @{thm refl} |> Morphism.thm (Local_Theory.target_morphism lthy))
  lthy
  |> tap (fn (thm, ctxt) => thm |> Thm.pretty_thm ctxt |> @{print}) |> snd\<close>
ML \<open>fun RLTHM b thm lthy = Relativization.RLTHM b thm lthy
  |> tap (fn (thm, ctxt) => thm |> Thm.pretty_thm ctxt |> @{print}) |> snd\<close>

(* SIMPLIFICATION RULES FOR THE RELATIVIZATION OF LOGICAL CONSTANTS *)

local_setup \<open> RLCST @{term "True"} \<close>
local_setup \<open> RLCST @{term "False"} \<close>
local_setup \<open> RLCST @{term "(\<and>)"} \<close>
local_setup \<open> RLCST @{term "(\<or>)"} \<close>
local_setup \<open> RLCST @{term "Not"} \<close>
local_setup \<open> RLCST @{term All} \<close>
local_setup \<open> RLCST @{term Ex} \<close>
local_setup \<open> RLCST @{term Ex1} \<close>

lemmas False_rlt_eq[simp] True_rlt_eq[simp]

(* Relativized connectives and quantifiers behave as expected: *)

lemma All_rlt_simp[simp]:
  "neper R \<Longrightarrow> All_rlt R \<phi> = (\<forall>x. R x x \<longrightarrow> \<phi> x)"
  unfolding All_rlt_def True_rlt_def rel_fun_eq rel_fun_def
    neper_def per_def by metis

lemma Ex_rlt_simp[simp]:
  "neper R \<Longrightarrow> Ex_rlt R \<phi> = (\<exists>x. R x x \<and> \<phi> x)"
  unfolding Ex_rlt_def True_rlt_def rel_fun_eq rel_fun_def
    neper_def per_def All_rlt_def by metis

lemma and_rlt_simp[simp]: "and_rlt P Q = (P \<and> Q)"
  unfolding rlt_eq ..

lemma or_rlt_simp[simp]: "or_rlt P Q = (P \<or> Q)"
  unfolding rlt_eq ..

lemma not_rlt_simp[simp]: "not_rlt P = (\<not> P)"
  by (simp only: not_rlt_def rlt_eq simp_thms)

lemma Ex1_rlt_simp[simp]:
  assumes "neper R"
  shows "Ex1_rlt R \<phi> = (\<exists>x. R x x \<and> \<phi> x \<and> (\<forall>y. R y y \<and> \<phi> y \<longrightarrow> R y x))"
  unfolding Ex1_rlt_def rel_fun_eq rel_fun_def
    neper_def per_def Ex_rlt_simp[OF assms] and_rlt_simp
    All_rlt_simp[OF assms] by auto

(* REALATIVIZATION OF TYPES *)

(* Products have a wide type definition *)
local_setup \<open> RLCST @{term Pair_Rep} \<close>

(* For simplicity and uniformity, switch from the defining set
Product_Type.prod to a defining predicate "tprod": *)
definition tprod :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> bool" where
  "tprod \<equiv> \<lambda>f. \<exists>a b. f = Pair_Rep a b"

lemma prod_tprod: "Product_Type.prod = Collect tprod"
  unfolding Product_Type.prod_def tprod_def ..

wide_typedef prod rel: "rel_prod" rep: "\<lambda>R1 R2 (a,b). Pair_Rep_rlt R1 R2 a b"
  via type_definition_prod[unfolded prod_tprod]
  subgoal for R1 R2 unfolding neper_def per_def
    apply safe
    subgoal premises prems
      using prems(7)
      by (simp add: prems(3,5)[rule_format])
    subgoal premises prems
      using prems(7,8)
      by (auto intro: prems(4,6)[rule_format, OF conjI])
    subgoal premises prems for a b
      using prems(1,2) by (auto intro: exI[of _ "(a, b)"])
    done
  subgoal unfolding neper_def per_def
  	by (simp add: prod.rel_eq)
  subgoal for R1 R2
    unfolding bij_upto_def
    apply safe
    subgoal for a b aa bb
      unfolding rel_fun_def rel_prod.simps Pair_Rep_rlt_def
        tprod_rlt_def restr_def[abs_def]
      apply auto
           apply (metis neper_def per_def)
          apply (metis neper_def per_def)
         apply (metis neper_def per_def)
        apply (metis neper_def per_def)
       apply (rule exI[of _ a], rule conjI)
        apply (metis neper_def per_def)
       apply (rule exI[of _ b], rule conjI)
        apply (metis neper_def per_def)
       apply (metis neper_def per_def)
      apply (rule exI[of _ a], rule conjI)
       apply (metis neper_def per_def)
      apply (rule exI[of _ b], rule conjI)
       apply (metis neper_def per_def)
      apply (metis neper_def per_def)
      done
    subgoal for a b aa bb
      unfolding rel_fun_def rel_prod.simps Pair_Rep_rlt_def
        tprod_rlt_def restr_def[abs_def] by auto
    subgoal for f
      unfolding rel_fun_def rel_prod.simps Pair_Rep_rlt_def
        tprod_rlt_def restr_def[abs_def] Ex_rlt_simp
      apply auto unfolding neper_def per_def apply safe
      subgoal for x xx a aa
        apply(rule exI[of _ x]) apply safe apply(rule exI[of _ xx])
        by meson .
    subgoal
      unfolding rel_fun_def rel_prod.simps Pair_Rep_rlt_def
        tprod_rlt_def restr_def[abs_def] Ex_rlt_simp and_rlt_simp
      unfolding neper_def per_def apply safe
      subgoal by meson
      subgoal by meson
      subgoal by blast
      subgoal by blast . .
  subgoal
    apply (simp add: fun_eq_iff Pair_Rep_rlt_def Rep_prod)
    apply (metis (mono_tags, lifting) Abs_prod_inverse Pair_Rep_def Pair_def Product_Type.prod_def mem_Collect_eq)
    done
  .

(* Sums have a wide type definition *)

(* For simplicity and uniformity, switch from the defining set
Sum_Type.sum to a defining predicate "t": *)
definition tsum :: "('a \<Rightarrow> 'b \<Rightarrow> bool \<Rightarrow> bool) \<Rightarrow> bool" where
  "tsum \<equiv> \<lambda>f. (\<exists>a. f = Inl_Rep a) \<or> (\<exists>b. f = Inr_Rep b)"

lemma sum_tsum: "Sum_Type.sum = Collect tsum"
  unfolding Sum_Type.sum_def tsum_def ..

local_setup \<open> RLCST @{term Inl_Rep} \<close>
local_setup \<open> RLCST @{term Inr_Rep} \<close>

wide_typedef sum rel: "rel_sum" rep: "\<lambda>R1 R2 a_b. case a_b of Inl a \<Rightarrow> Inl_Rep_rlt R1 R2 a
                                        |Inr b \<Rightarrow> Inr_Rep_rlt R2 R1 b"
  via type_definition_sum[unfolded sum_tsum]
  subgoal for R1 R2 unfolding neper_def per_def
    apply safe
    subgoal premises prems for a b c d
      using prems(7)
      by (cases c; cases d; simp add: prems(3,5)[rule_format])
    subgoal premises prems for a b c d e
      using prems(7,8)
      by (cases c; cases d; cases e; auto intro: prems(4,6)[rule_format, OF conjI])
    subgoal premises prems for a b
      using prems(1) by (auto intro: exI[of _ "Inl a"])
    done
  subgoal unfolding neper_def per_def
    using sum.rel_eq by blast
  subgoal for R1 R2 unfolding bij_upto_def
    apply safe
    subgoal for a b
      unfolding rel_fun_def rel_prod.simps Inl_Rep_rlt_def Inr_Rep_rlt_def
        tsum_rlt_def restr_def[abs_def] or_rlt_simp and_rlt_simp
      apply (auto split: sum.splits)
      by (metis neper_def per_def)+
    subgoal for a b
      unfolding rel_fun_def rel_prod.simps Inl_Rep_rlt_def Inr_Rep_rlt_def
        tsum_rlt_def restr_def[abs_def] or_rlt_simp and_rlt_simp
      apply (auto split: sum.splits)
      by (metis neper_def)+
    subgoal for f
      unfolding rel_fun_def rel_prod.simps Pair_Rep_rlt_def
        tprod_rlt_def restr_def[abs_def] Ex_rlt_simp
      apply auto unfolding tsum_rlt_def Inl_Rep_rlt_def
        Inr_Rep_rlt_def
        and_rlt_simp or_rlt_simp Ex_rlt_simp All_rlt_simp
        rel_fun_def rlt_eq apply safe
      subgoal for a
        apply(rule exI[of _ "Inl a"]) apply safe
      	subgoal by simp
        subgoal by simp
        subgoal by simp
        subgoal by (metis (no_types, lifting) neper_def old.sum.simps(5) per_def) .
      subgoal for b
        apply(rule exI[of _ "Inr b"]) apply safe
        subgoal by simp
        subgoal by simp
        subgoal by simp
        subgoal by (metis (no_types, lifting) neper_def old.sum.simps(6) per_def) . .
    subgoal for f
      unfolding rel_fun_def rel_prod.simps Pair_Rep_rlt_def
        tprod_rlt_def restr_def[abs_def] Ex_rlt_simp
      by simp_all (metis (no_types, lifting) neper_def per_def)+ .
  subgoal by (auto simp: fun_eq_iff Inl_Rep_rlt_def Inr_Rep_rlt_def Inl_def Inr_def Abs_sum_inverse Inl_RepI Inr_RepI Inl_Rep_def Inr_Rep_def
        split: sum.splits) .

definition "Rep_set = (\<lambda>X x. x \<in> X)"
lemma type_definition_set: "type_definition Rep_set Collect {P. True}"
  by standard (auto simp: fun_eq_iff Rep_set_def)

(* The PER closure: *)
definition perClassCl where "perClassCl A R a \<equiv> \<exists>a'. A a' \<and> R a' a"

wide_typedef set rel: "rel_set"  rep: "\<lambda>R A. perClassCl (\<lambda>a. a \<in> A) R" via type_definition_set
  subgoal by (meson neper_def neper_rel_set)
  subgoal by simp
  subgoal for R
    subgoal unfolding rel_fun_def rel_set_def perClassCl_def bij_upto_def restr_def
      apply (simp only: Rep_set_def rlt_eq) apply safe
      subgoal by (metis neper_def per_def)
      subgoal by (metis neper_def per_def)
      subgoal by (metis neper_def per_def)
      subgoal by metis
      subgoal for f apply(rule exI[of _ "Collect (perClassCl f R)"])
        unfolding neper_def per_def perClassCl_def mem_Collect_eq by blast
      subgoal by (metis neper_def per_def)
      subgoal by (metis neper_def per_def) . .
  subgoal
    by (auto simp: perClassCl_def fun_eq_iff Rep_set_def)
  .

local_setup \<open> fn lthy => Relativization.register_quasidef
  \<^const_name>\<open>Set.member\<close>
  ({c=\<^term>\<open>(\<in>)::'a \<Rightarrow> 'a set \<Rightarrow> bool\<close>, rhs=Relativization.Original \<^term>\<open>\<lambda>(x::'a) (X :: 'a set). Rep_set X x\<close>}
  |> Relativization.morph_quasidef (Morphism.term_morphism "polymorphic"
      (singleton (Variable.polymorphic lthy))))
  lthy \<close>

local_setup \<open> fn lthy => Relativization.register_quasidef
  \<^const_name>\<open>Pure.type\<close>
  ({c=\<^term>\<open>undefined :: 'a\<close>, rhs=Relativization.Original \<^term>\<open>SOME x :: 'a. True\<close>}
  |> Relativization.morph_quasidef (Morphism.term_morphism "polymorphic"
      (singleton (Variable.polymorphic lthy))))
  lthy \<close>

local_setup \<open> fn lthy => Relativization.register_quasidef
  \<^const_name>\<open>Pure.type\<close>
  ({c=\<^term>\<open>TYPE('a)\<close>, rhs=Relativization.Original \<^term>\<open>Abs_itself ()\<close>}
  |> Relativization.morph_quasidef (Morphism.term_morphism "polymorphic"
      (singleton (Variable.polymorphic lthy))))
  lthy \<close>

lemma type_definition_unit: "type_definition Rep_unit Abs_unit {x. x}"
  using type_definition_unit
    arg_cong[where f="type_definition Rep_unit Abs_unit" and x = "{x. x}" and y = "{True}"]
  by (auto simp: type_definition_def)

wide_typedef unit rel: "(=) :: unit rel" rep: "\<lambda>_. True" via type_definition_unit
  by (auto simp: neper_def per_def bij_upto_def restr_def fun_eq_iff Rep_unit[simplified])

lemma Nat_nonempty: "\<exists>x. Nat x"
  using Zero_RepI by blast

local_setup \<open> RLCST @{term Nat}\<close>
local_setup \<open> RLCST @{term Ball} \<close>
local_setup \<open> RLCST @{term Bex} \<close>
local_setup \<open> RLCST @{term "(\<subseteq>)"} \<close>
local_setup \<open> RLCST @{term UNIV} \<close>

lemma member_rlt_simp[simp]:
  "member_rlt R x A \<longleftrightarrow> (\<exists>a'. a' \<in> A \<and> R a' x)"
  unfolding member_rlt_def Rep_set_rlt_def perClassCl_def by simp

lemma neper_rel_set_iff:
  "neper R \<Longrightarrow> rel_set R A A \<longleftrightarrow> A \<subseteq> {x. R x x}"
  unfolding rel_set_def neper_def per_def
  by (meson Ball_Collect)

lemma less_eq_set_rlt[simp]:
  "neper R \<Longrightarrow> rel_set R A A \<Longrightarrow> rel_set R B B \<Longrightarrow>
 less_eq_set_rlt R A B \<longleftrightarrow> {x. \<exists>a'\<in>A. R a' x} \<subseteq> {x. \<exists>a'\<in>B. R a' x}"
  unfolding less_eq_set_rlt_def Set.less_eq_set_rlt_def less_eq_fun_rlt_def
    le_fun_rlt_def less_eq_bool_rlt_def le_bool_rlt_def apply (simp add: neper_rel_set_iff)
  by auto (metis neper_def per_def)

lemma Ball_rlt_simp[simp]:
  "neper R \<Longrightarrow> Ball_rlt R A \<phi> = (\<forall>x a. a \<in> A \<and> R a x \<longrightarrow> \<phi> x)"
  unfolding Ball_rlt_def by simp (metis neper_per per_def)

lemma Bex_rlt_simp[simp]:
  "neper R \<Longrightarrow> Bex_rlt R A \<phi> = (\<exists>x a. a \<in> A \<and> R a x \<and> \<phi> x)"
  unfolding Bex_rlt_def by simp (metis neper_per per_def)

axiomatization where Collect_rlt_simp[simp]:
  "Collect_rlt = (\<lambda>R p. {x. R x x \<and> p x})"

lemma top_bool_rlt_simp[simp]:
  "top_bool_rlt = True"
  unfolding top_bool_rlt_def Orderings.top_bool_rlt_def rlt_eq by auto

lemma top_fun_rlt_simp[simp]:
  "top_fun_rlt R S t = (\<lambda>_. t)"
  unfolding top_fun_rlt_def Orderings.top_fun_rlt_def by auto

lemma top_set_rlt_simp[simp]:
  "neper R \<Longrightarrow> top_set_rlt R = {x. R x x}"
  unfolding top_set_rlt_def Set.top_set_rlt_def
  by (subst Collect_rlt_simp) simp

wide_typedef nat rel: "(=) :: nat rel" rep: Rep_Nat
  by (auto simp only: restr_eq rlt_eq type_definition_bij_upto[OF type_definition_nat])

lemmas bij_upto_simps[bij_upto] = top_set_rlt_def Set.top_set_rlt_def top_bool_rlt_simp
  Collect_rlt_simp top_fun_rlt_simp member_rlt_simp
  simp_thms mem_Collect_eq rel_fun_True restr_self restr_True

wide_typedef itself rel: "\<lambda>R. (=) :: _ itself rel" rep: "\<lambda>R. Rep_itself" via type_definition_itself
  by (auto simp: type_definition_bij_upto[OF type_definition_itself] restr_eq)

ML \<open>val _ = Theory.setup (BNF_FP_Def_Sugar.fp_sugars_interpretation Wide_Datatype.wide_plugin Wide_Datatype.generate_wide);\<close>

local_setup \<open>RLCST @{term set}\<close>
local_setup \<open>RLCST @{term digit7}\<close>

wide_typedef String.literal rel: "(=) :: String.literal rel" rep: literal.explode
  by (auto simp only: restr_eq rlt_eq rrel_eq type_definition_bij_upto[OF String.type_definition_literal])

local_setup \<open>RLCST @{term intrel}\<close>

wide_typedef int rel: "(=) :: int rel" rep: Rep_int
  by (auto simp only: restr_eq rlt_eq rrel_eq type_definition_bij_upto[OF type_definition_int])

local_setup \<open>RLCST @{term fst}\<close>
local_setup \<open>RLCST @{term inj_on}\<close>
local_setup \<open>RLTHM @{binding the_equality_rlt} @{thm the_equality}\<close>
local_setup \<open>RLTHM @{binding someI2_ex_rlt} @{thm someI2_ex}\<close>

lemma INV_rlt_INV:
  assumes inj_rlt_strong: "\<forall>x y. A x x \<and> B (f_rlt x) (f y) \<longrightarrow> A x y"
    and x_f: "x \<in> range f"
    and "\<forall>a aa. A a a \<and> B (f_rlt a) x_rlt \<and> f aa = x \<longrightarrow> A a aa"
    and surj: "\<exists>x. A x x \<and> B (f_rlt x) x_rlt"
  shows "neper A \<Longrightarrow> neper B \<Longrightarrow>
  rel_fun A B f_rlt f_rlt \<Longrightarrow> B x_rlt x_rlt \<Longrightarrow>
  A (INV_rlt A B f_rlt x_rlt) (INV f x)"
  apply (auto simp: INV_rlt_def INV_def)
  apply (rule someI2_ex_rlt[where Q="\<lambda>x_rlt. A x_rlt (SOME a. f a = x)"])
      apply assumption
     apply (simp add: rel_fun_def)
  using neper_classes_eq apply fastforce
    apply (simp add: rel_fun_def)
    apply (metis (mono_tags, lifting) CollectD CollectI neper_classes_eq)
   apply simp
   apply (metis surj)
  apply (rule someI2_ex[where Q="\<lambda>x. A _ x"])
   apply (metis (mono_tags, lifting) x_f image_iff)
  apply (metis (mono_tags, lifting) assms(3))
  done

lemma Pair_rlt_Pair: "neper R \<Longrightarrow> neper S \<Longrightarrow>
  rel_fun R (rel_fun S (rel_prod R S)) (Pair_rlt R S) Pair"
  unfolding Pair_rlt_def Pair_Rep_rlt_def Abs_prod_rlt_def Rep_prod_rlt_def
    Pair_def Pair_Rep_def Abs_prod_qdef Rep_prod[simplified]
    prod.rep_eq[symmetric]
  apply (intro rel_funI)
  apply simp
  apply (rule INV_rlt_INV[where A="rel_prod R S"])
  subgoal for x y xx yy
    apply (auto simp: rel_fun_def)
    done
  subgoal
    apply (auto simp: rel_fun_def)
    done
  subgoal
    apply (auto simp: rel_fun_def)
     apply (metis (mono_tags, lifting) mem_Collect_eq neper_classes_eq)
    apply (metis (mono_tags, lifting) mem_Collect_eq neper_classes_eq)
    done
      apply (simp_all only: neper)
    apply (auto simp: rel_fun_def)
          apply (metis neper_def per_def)
         apply (metis neper_def per_def)
        apply (metis neper_def per_def)
       apply (metis neper_def per_def)
      apply (metis neper_def per_def)
     apply (metis neper_def per_def)
    apply (metis neper_def per_def)
   apply (metis neper_def per_def)
  apply (metis neper_def per_def)
  done

lemma case_prod_rlt_case_prod: "neper R \<Longrightarrow> neper S \<Longrightarrow> neper T \<Longrightarrow>
  rel_fun (rel_fun R (rel_fun S T)) (rel_fun (rel_prod R S) T)
    (case_prod_rlt R S T) case_prod"
  unfolding case_prod_rlt_def fun_eq_iff rel_fun_def
  apply safe
  apply (rule the_equality_rlt[of T])
      apply assumption
     apply (metis neper_def per_def rel_prod_inject)
    apply (auto simp add: rel_fun_def)
  apply (metis neper_def per_def)
    apply (metis neper_def per_def)
  subgoal for x y a b aa ba
    apply (intro exI[of _ a] exI[of _ b] conjI)
       apply (meson neper_per per_def)
      apply (meson neper_per per_def)
     apply (rule prod.rel_flip[THEN iffD1])
     apply (simp add: neper_conversep[symmetric])
     apply (rule Pair_rlt_Pair[THEN rel_funD, THEN rel_funD])
        apply assumption
       apply assumption
      apply (meson neper_per per_def)
     apply (meson neper_per per_def)
    apply (meson neper_per per_def)
    done
  subgoal for x y a b aa bb z aaa bbb
    apply (subgoal_tac "rel_prod R S (a, b) (aaa, bbb)")
    prefer 2
     apply (rule prod.rel_transp[THEN transpD])
    apply (metis neper_def per_def transpI)
       apply (metis neper_def per_def transpI)
    apply assumption
     apply (rule Pair_rlt_Pair[THEN rel_funD, THEN rel_funD])
        apply assumption
       apply assumption
      apply (meson neper_per per_def)
     apply (meson neper_per per_def)
    apply (metis (no_types, lifting) mem_Collect_eq neper_classes_eq rel_prod_inject)
    done
  done

lemma fst_rlt_fst: "neper R \<Longrightarrow> neper S \<Longrightarrow> rel_fun (rel_prod R S) R (fst_rlt R S) fst"
  unfolding fst_rlt_def fst_def
  apply (rule rel_funI)
  apply (rule case_prod_rlt_case_prod[THEN rel_funD, THEN rel_funD, of R S R])
  apply auto
  done

lemma snd_rlt_snd: "neper R \<Longrightarrow> neper S \<Longrightarrow> rel_fun (rel_prod R S) S (snd_rlt R S) snd"
  unfolding snd_rlt_def snd_def
  apply (rule rel_funI)
  apply (rule case_prod_rlt_case_prod[THEN rel_funD, THEN rel_funD, of R S S])
  apply auto
  done

lemma id_rlt_simp[simp]: "id_rlt R = id"
unfolding id_rlt_def by auto

end


theory conditions_relativized
  imports conditions_negative
begin

(****************** Relativized order and equality relations ****************)
definition subset_in::\<open>'p \<sigma> \<Rightarrow> 'p \<sigma> \<Rightarrow> 'p \<sigma> \<Rightarrow> bool\<close> ("_\<preceq>\<^sub>__")
  where \<open>A \<preceq>\<^sub>U B \<equiv> \<forall>x. U x \<longrightarrow> (A x \<longrightarrow> B x)\<close>
definition subset_out::\<open>'p \<sigma> \<Rightarrow> 'p \<sigma> \<Rightarrow> 'p \<sigma> \<Rightarrow> bool\<close> ("_\<preceq>\<^sup>__")
  where \<open>A \<preceq>\<^sup>U B \<equiv> \<forall>x. \<not>U x \<longrightarrow> (A x \<longrightarrow> B x)\<close>

definition setequ_in::\<open>'p \<sigma> \<Rightarrow> 'p \<sigma> \<Rightarrow> 'p \<sigma> \<Rightarrow> bool\<close> ("_\<approx>\<^sub>__")
  where \<open>A \<approx>\<^sub>U B \<equiv> \<forall>x. U x \<longrightarrow> (A x \<longleftrightarrow> B x)\<close>
definition setequ_out::\<open>'p \<sigma> \<Rightarrow> 'p \<sigma> \<Rightarrow> 'p \<sigma> \<Rightarrow> bool\<close> ("_\<approx>\<^sup>__")
  where \<open>A \<approx>\<^sup>U B \<equiv> \<forall>x. \<not>U x \<longrightarrow> (A x \<longleftrightarrow> B x)\<close>

declare subset_in_def[order] subset_out_def[order] setequ_in_def[order] setequ_out_def[order]

lemma subset_in_out: "(let U=C in (A \<preceq>\<^sub>U B)) = (let U=\<^bold>\<midarrow>C in (A \<preceq>\<^sup>U B))" by (simp add: compl_def subset_in_def subset_out_def)
lemma setequ_in_out: "(let U=C in (A \<approx>\<^sub>U B)) = (let U=\<^bold>\<midarrow>C in (A \<approx>\<^sup>U B))" by (simp add: compl_def setequ_in_def setequ_out_def)

lemma subset_in_char: "(A \<preceq>\<^sub>U B) = (U \<^bold>\<and> A \<preceq> U \<^bold>\<and> B)" unfolding order conn by blast
lemma subset_out_char: "(A \<preceq>\<^sup>U B) = (U \<^bold>\<or> A \<preceq> U \<^bold>\<or> B)" unfolding order conn by blast
lemma setequ_in_char: "(A \<approx>\<^sub>U B) = (U \<^bold>\<and> A \<approx> U \<^bold>\<and> B)" unfolding order conn by blast
lemma setequ_out_char: "(A \<approx>\<^sup>U B) = (U \<^bold>\<or> A \<approx> U \<^bold>\<or> B)" unfolding order conn by blast

(**Relativization cannot be meaningfully applied to conditions (n)NORM or (n)DNRM.*)
lemma "NORM \<phi>  = (let U = \<^bold>\<top> in ((\<phi> \<^bold>\<bottom>) \<approx>\<^sub>U \<^bold>\<bottom>))" by (simp add: NORM_def setequ_def setequ_in_def top_def)
lemma "(let U = \<^bold>\<bottom> in ((\<phi> \<^bold>\<bottom>) \<approx>\<^sub>U \<^bold>\<bottom>))" by (simp add: bottom_def setequ_in_def)

(*Relativization ('in' resp. 'out') leaves (n)EXPN/(n)CNTR unchanged or trivializes them.*)
lemma "EXPN \<phi>  = (\<forall>A. A \<preceq>\<^sub>A \<phi> A)" by (simp add: EXPN_def subset_def subset_in_def)
lemma "CNTR \<phi>  = (\<forall>A. (\<phi> A) \<preceq>\<^sup>A A)" by (metis (mono_tags, lifting) CNTR_def subset_def subset_out_def)
lemma "\<forall>A. A \<preceq>\<^sup>A \<phi> A" by (simp add: subset_out_def)
lemma "\<forall>A. (\<phi> A) \<preceq>\<^sub>A A" by (simp add: subset_in_def)

(****************** Relativized ADDI variants ****************)

definition ADDIr::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("ADDIr")
  where "ADDIr \<phi>  \<equiv> \<forall>A B. let U = (A \<^bold>\<or> B) in      (\<phi>(A \<^bold>\<or> B) \<approx>\<^sup>U (\<phi> A) \<^bold>\<or> (\<phi> B))"
definition ADDIr_a::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("ADDIr\<^sup>a")
  where "ADDIr\<^sup>a \<phi> \<equiv> \<forall>A B. let U = (A \<^bold>\<or> B) in      (\<phi>(A \<^bold>\<or> B) \<preceq>\<^sup>U (\<phi> A) \<^bold>\<or> (\<phi> B))"
definition ADDIr_b::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("ADDIr\<^sup>b")
  where "ADDIr\<^sup>b \<phi> \<equiv> \<forall>A B. let U = (A \<^bold>\<or> B) in ((\<phi> A) \<^bold>\<or> (\<phi> B) \<preceq>\<^sup>U \<phi>(A \<^bold>\<or> B))"

declare ADDIr_def[cond] ADDIr_a_def[cond] ADDIr_b_def[cond]

lemma ADDIr_char: "ADDIr \<phi> = (ADDIr\<^sup>a \<phi> \<and> ADDIr\<^sup>b \<phi>)" unfolding cond by (meson setequ_char setequ_out_char subset_out_char)

lemma ADDIr_a_impl: "ADDI\<^sup>a \<phi> \<longrightarrow> ADDIr\<^sup>a \<phi>" by (simp add: ADDI_a_def ADDIr_a_def subset_def subset_out_def)
lemma ADDIr_a_equ:  "EXPN \<phi> \<Longrightarrow> ADDIr\<^sup>a \<phi> = ADDI\<^sup>a \<phi>" unfolding cond by (smt (verit, del_insts) join_def subset_def subset_out_def)
lemma ADDIr_a_equ':"nEXPN \<phi> \<Longrightarrow> ADDIr\<^sup>a \<phi> = ADDI\<^sup>a \<phi>" unfolding cond by (smt (verit, ccfv_threshold) compl_def subset_def subset_out_def)

lemma ADDIr_b_impl: "ADDI\<^sup>b \<phi> \<longrightarrow> ADDIr\<^sup>b \<phi>" by (simp add: ADDI_b_def ADDIr_b_def subset_def subset_out_def)
lemma "nEXPN \<phi> \<Longrightarrow> ADDIr\<^sup>b \<phi> \<longrightarrow> ADDI\<^sup>b \<phi>" nitpick oops
lemma ADDIr_b_equ: "EXPN \<phi> \<Longrightarrow> ADDIr\<^sup>b \<phi> = ADDI\<^sup>b \<phi>" unfolding cond by (smt (z3) subset_def subset_out_def)

(****************** Relativized MULT variants ****************)

definition MULTr::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("MULTr")
  where "MULTr \<phi>  \<equiv> \<forall>A B. let U = (A \<^bold>\<and> B) in      (\<phi>(A \<^bold>\<and> B) \<approx>\<^sub>U (\<phi> A) \<^bold>\<and> (\<phi> B))"
definition MULTr_a::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("MULTr\<^sup>a")
  where "MULTr\<^sup>a \<phi> \<equiv> \<forall>A B. let U = (A \<^bold>\<and> B) in      (\<phi>(A \<^bold>\<and> B) \<preceq>\<^sub>U (\<phi> A) \<^bold>\<and> (\<phi> B))"
definition MULTr_b::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("MULTr\<^sup>b")
  where "MULTr\<^sup>b \<phi> \<equiv> \<forall>A B. let U = (A \<^bold>\<and> B) in ((\<phi> A) \<^bold>\<and> (\<phi> B) \<preceq>\<^sub>U \<phi>(A \<^bold>\<and> B))"

declare MULTr_def[cond] MULTr_a_def[cond] MULTr_b_def[cond]

lemma MULTr_char: "MULTr \<phi> = (MULTr\<^sup>a \<phi> \<and> MULTr\<^sup>b \<phi>)" unfolding cond by (meson setequ_char setequ_in_char subset_in_char)

lemma MULTr_a_impl: "MULT\<^sup>a \<phi> \<longrightarrow> MULTr\<^sup>a \<phi>" by (simp add: MULT_a_def MULTr_a_def subset_def subset_in_def)
lemma "nCNTR \<phi> \<Longrightarrow> MULTr\<^sup>a \<phi> \<longrightarrow> MULT\<^sup>a \<phi>" nitpick oops
lemma MULTr_a_equ: "CNTR \<phi> \<Longrightarrow> MULTr\<^sup>a \<phi> = MULT\<^sup>a \<phi>" unfolding cond by (smt (verit, del_insts) subset_def subset_in_def)

lemma MULTr_b_impl: "MULT\<^sup>b \<phi> \<longrightarrow> MULTr\<^sup>b \<phi>" by (simp add: MULT_b_def MULTr_b_def subset_def subset_in_def)
lemma "MULTr\<^sup>b \<phi> \<longrightarrow> MULT\<^sup>b \<phi>" nitpick oops
lemma MULTr_b_equ:  "CNTR \<phi> \<Longrightarrow> MULTr\<^sup>b \<phi> = MULT\<^sup>b \<phi>" unfolding cond by (smt (verit, del_insts) meet_def subset_def subset_in_def)
lemma MULTr_b_equ':"nCNTR \<phi> \<Longrightarrow> MULTr\<^sup>b \<phi> = MULT\<^sup>b \<phi>" unfolding cond by (smt (z3) compl_def subset_def subset_in_def)

(**** Weak variants of monotonicity ***)
definition MONOw1::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("MONOw\<^sup>1")
  where "MONOw\<^sup>1 \<phi> \<equiv> \<forall>A B. A \<preceq> B \<longrightarrow> (\<phi> A) \<preceq> B \<^bold>\<or> (\<phi> B)"
definition MONOw2::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("MONOw\<^sup>2")
  where "MONOw\<^sup>2 \<phi> \<equiv> \<forall>A B. A \<preceq> B \<longrightarrow> A \<^bold>\<and> (\<phi> A) \<preceq> (\<phi> B)"

declare MONOw1_def[cond] MONOw2_def[cond]

lemma MONOw1_ADDIr_b: "MONOw\<^sup>1 \<phi> = ADDIr\<^sup>b \<phi>" proof -
  have l2r: "MONOw\<^sup>1 \<phi> \<longrightarrow> ADDIr\<^sup>b \<phi>"  unfolding cond subset_out_char by (metis (mono_tags, opaque_lifting) L7 join_def subset_def)
  have r2l: "ADDIr\<^sup>b \<phi> \<longrightarrow> MONOw\<^sup>1 \<phi>" unfolding cond subset_out_char by (metis (full_types) L9 join_def setequ_ext subset_def)
  show ?thesis using l2r r2l by blast
qed
lemma MONOw2_MULTr_a: "MONOw\<^sup>2 \<phi> = MULTr\<^sup>a \<phi>" proof -
  have l2r: "MONOw\<^sup>2 \<phi> \<longrightarrow> MULTr\<^sup>a \<phi>" unfolding cond subset_in_char by (meson L4 L5 L8 L9)
  have r2l:"MULTr\<^sup>a \<phi> \<longrightarrow> MONOw\<^sup>2 \<phi>" unfolding cond subset_in_char by (metis BA_distr1 L2 L5 L6 L9 setequ_ext)
  show ?thesis using l2r r2l by blast
qed

lemma MONOw1_impl: "MONO \<phi> \<longrightarrow> MONOw\<^sup>1 \<phi>" by (simp add: ADDIr_b_impl MONO_ADDIb MONOw1_ADDIr_b)
lemma "MONOw\<^sup>1 \<phi> \<longrightarrow> MONO \<phi>" nitpick oops
lemma MONOw2_impl: "MONO \<phi> \<longrightarrow> MONOw\<^sup>2 \<phi>" by (simp add: MONO_MULTa MONOw2_MULTr_a MULTr_a_impl)
lemma "MONOw\<^sup>2 \<phi> \<longrightarrow> MONO \<phi>" nitpick oops

(** We have in fact that (n)CNTR (resp. (n)EXPN) implies MONOw\<^sup>1/ADDIr\<^sup>b (resp. MONOw\<^sup>2/MULTr\<^sup>a) *)
lemma CNTR_MONOw1_impl: "CNTR \<phi> \<longrightarrow> MONOw\<^sup>1 \<phi>" by (metis CNTR_def L3 MONOw1_def subset_char1)
lemma nCNTR_MONOw1_impl: "nCNTR \<phi> \<longrightarrow> MONOw\<^sup>1 \<phi>" by (smt (verit, ccfv_threshold) MONOw1_def compl_def join_def nCNTR_def subset_def)
lemma EXPN_MONOw2_impl: "EXPN \<phi> \<longrightarrow> MONOw\<^sup>2 \<phi>" by (metis EXPN_def L4 MONOw2_def subset_char1)
lemma nEXPN_MONOw2_impl: "nEXPN \<phi> \<longrightarrow> MONOw\<^sup>2 \<phi>" by (smt (verit) MONOw2_def compl_def meet_def nEXPN_def subset_def)

(****************** Relativized nADDI variants ****************)

definition nADDIr::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("nADDIr")
  where "nADDIr \<phi>  \<equiv> \<forall>A B. let U = (A \<^bold>\<or> B) in      (\<phi>(A \<^bold>\<or> B) \<approx>\<^sup>U (\<phi> A) \<^bold>\<and> (\<phi> B))"
definition nADDIr_a::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("nADDIr\<^sup>a")
  where "nADDIr\<^sup>a \<phi> \<equiv> \<forall>A B. let U = (A \<^bold>\<or> B) in ((\<phi> A) \<^bold>\<and> (\<phi> B) \<preceq>\<^sup>U \<phi>(A \<^bold>\<or> B))"
definition nADDIr_b::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("nADDIr\<^sup>b")
  where "nADDIr\<^sup>b \<phi> \<equiv> \<forall>A B. let U = (A \<^bold>\<or> B) in      (\<phi>(A \<^bold>\<or> B) \<preceq>\<^sup>U (\<phi> A) \<^bold>\<and> (\<phi> B))"

declare nADDIr_def[cond] nADDIr_a_def[cond] nADDIr_b_def[cond]

lemma nADDIr_char: "nADDIr \<phi> = (nADDIr\<^sup>a \<phi> \<and> nADDIr\<^sup>b \<phi>)" unfolding cond by (meson setequ_char setequ_out_char subset_out_char)

lemma nADDIr_a_impl: "nADDI\<^sup>a \<phi> \<longrightarrow> nADDIr\<^sup>a \<phi>" unfolding cond by (simp add: subset_def subset_out_def)
lemma "nADDIr\<^sup>a \<phi> \<longrightarrow> nADDI\<^sup>a \<phi>" nitpick oops
lemma nADDIr_a_equ:  "EXPN \<phi> \<Longrightarrow> nADDIr\<^sup>a \<phi> = nADDI\<^sup>a \<phi>" unfolding cond by (smt (z3) subset_def subset_out_def)
lemma nADDIr_a_equ':"nEXPN \<phi> \<Longrightarrow> nADDIr\<^sup>a \<phi> = nADDI\<^sup>a \<phi>" unfolding cond by (smt (z3) compl_def join_def meet_def subset_def subset_out_def)

lemma nADDIr_b_impl: "nADDI\<^sup>b \<phi> \<longrightarrow> nADDIr\<^sup>b \<phi>" by (simp add: nADDI_b_def nADDIr_b_def subset_def subset_out_def)
lemma "EXPN \<phi> \<Longrightarrow> nADDIr\<^sup>b \<phi> \<longrightarrow> nADDI\<^sup>b \<phi>" nitpick oops
lemma nADDIr_b_equ: "nEXPN \<phi> \<Longrightarrow> nADDIr\<^sup>b \<phi> = nADDI\<^sup>b \<phi>" unfolding cond by (smt (z3) compl_def subset_def subset_out_def)

(****************** Relativized nMULT variants ****************)

definition nMULTr::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("nMULTr")
  where "nMULTr \<phi>  \<equiv> \<forall>A B. let U = (A \<^bold>\<and> B) in      (\<phi>(A \<^bold>\<and> B) \<approx>\<^sub>U (\<phi> A) \<^bold>\<or> (\<phi> B))"
definition nMULTr_a::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("nMULTr\<^sup>a")
  where "nMULTr\<^sup>a \<phi> \<equiv> \<forall>A B. let U = (A \<^bold>\<and> B) in ((\<phi> A) \<^bold>\<or> (\<phi> B) \<preceq>\<^sub>U \<phi>(A \<^bold>\<and> B))"
definition nMULTr_b::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("nMULTr\<^sup>b")
  where "nMULTr\<^sup>b \<phi> \<equiv> \<forall>A B. let U = (A \<^bold>\<and> B) in      (\<phi>(A \<^bold>\<and> B) \<preceq>\<^sub>U (\<phi> A) \<^bold>\<or> (\<phi> B))"

declare nMULTr_def[cond] nMULTr_a_def[cond] nMULTr_b_def[cond]

lemma nMULTr_char: "nMULTr \<phi> = (nMULTr\<^sup>a \<phi> \<and> nMULTr\<^sup>b \<phi>)" unfolding cond by (meson setequ_char setequ_in_char subset_in_char)

lemma nMULTr_a_impl: "nMULT\<^sup>a \<phi> \<longrightarrow> nMULTr\<^sup>a \<phi>" by (simp add: nMULT_a_def nMULTr_a_def subset_def subset_in_def)
lemma "CNTR \<phi> \<Longrightarrow> nMULTr\<^sup>a \<phi> \<longrightarrow> nMULT\<^sup>a \<phi>" nitpick oops
lemma nMULTr_a_equ: "nCNTR \<phi> \<Longrightarrow> nMULTr\<^sup>a \<phi> = nMULT\<^sup>a \<phi>" unfolding cond by (smt (z3) compl_def subset_def subset_in_def)

lemma nMULTr_b_impl: "nMULT\<^sup>b \<phi> \<longrightarrow> nMULTr\<^sup>b \<phi>" by (simp add: nMULT_b_def nMULTr_b_def subset_def subset_in_def)
lemma "nMULTr\<^sup>b \<phi> \<longrightarrow> nMULT\<^sup>b \<phi>" nitpick oops
lemma nMULTr_b_equ:  "CNTR \<phi> \<Longrightarrow> nMULTr\<^sup>b \<phi> = nMULT\<^sup>b \<phi>" unfolding cond by (smt (z3) compl_def join_def meet_def subset_def subset_in_def)
lemma nMULTr_b_equ':"nCNTR \<phi> \<Longrightarrow> nMULTr\<^sup>b \<phi> = nMULT\<^sup>b \<phi>" unfolding cond by (smt (z3) compl_def join_def meet_def subset_def subset_in_def)

(**** Weak variants of antitonicity ***)
definition ANTIw1::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("ANTIw\<^sup>1")
  where "ANTIw\<^sup>1 \<phi> \<equiv> \<forall>A B. A \<preceq> B \<longrightarrow> (\<phi> B) \<preceq> B \<^bold>\<or> (\<phi> A)"
definition ANTIw2::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("ANTIw\<^sup>2")
  where "ANTIw\<^sup>2 \<phi> \<equiv> \<forall>A B. A \<preceq> B \<longrightarrow> A \<^bold>\<and> (\<phi> B) \<preceq> (\<phi> A)"

declare ANTIw1_def[cond] ANTIw2_def[cond]

lemma ANTIw1_nADDIr_b: "ANTIw\<^sup>1 \<phi> = nADDIr\<^sup>b \<phi>" proof -
  have l2r: "ANTIw\<^sup>1 \<phi> \<longrightarrow> nADDIr\<^sup>b \<phi>" unfolding cond subset_out_char by (smt (verit, ccfv_SIG) BA_distr2 L8 join_def setequ_ext subset_def)
  have r2l: "nADDIr\<^sup>b \<phi> \<longrightarrow> ANTIw\<^sup>1 \<phi>" unfolding cond subset_out_def by (metis (full_types) L9 join_def meet_def setequ_ext subset_def)
  show ?thesis using l2r r2l by blast
qed
lemma ANTIw2_nMULTr_a: "ANTIw\<^sup>2 \<phi> = nMULTr\<^sup>a \<phi>" proof -
  have l2r: "ANTIw\<^sup>2 \<phi> \<longrightarrow> nMULTr\<^sup>a \<phi>" unfolding cond subset_in_char by (metis BA_distr1 L3 L4 L5 L7 L8 setequ_ext)
  have r2l: "nMULTr\<^sup>a \<phi> \<longrightarrow> ANTIw\<^sup>2 \<phi>" unfolding cond subset_in_def by (metis (full_types) L10 join_def meet_def setequ_ext subset_def)
  show ?thesis using l2r r2l by blast
qed

lemma "ANTI \<phi> \<longrightarrow> ANTIw\<^sup>1 \<phi>" by (simp add: ANTI_nADDIb ANTIw1_nADDIr_b nADDIr_b_impl)
lemma "ANTIw\<^sup>1 \<phi> \<longrightarrow> ANTI \<phi>" nitpick oops
lemma "ANTI \<phi> \<longrightarrow> ANTIw\<^sup>2 \<phi>" by (simp add: ANTI_nMULTa ANTIw2_nMULTr_a nMULTr_a_impl)
lemma "ANTIw\<^sup>2 \<phi> \<longrightarrow> ANTI \<phi>" nitpick oops

(** We have in fact that (n)CNTR (resp. (n)EXPN) implies ANTIw\<^sup>1/nADDIr\<^sup>b (resp. ANTIw\<^sup>2/nMULTr\<^sup>a) *)
lemma CNTR_ANTIw1_impl: "CNTR \<phi> \<longrightarrow> ANTIw\<^sup>1 \<phi>" unfolding cond using L3 subset_char1 by blast
lemma nCNTR_ANTIw1_impl: "nCNTR \<phi> \<longrightarrow> ANTIw\<^sup>1 \<phi>" unfolding cond by (metis (full_types) compl_def join_def subset_def)
lemma EXPN_ANTIw2_impl: "EXPN \<phi> \<longrightarrow> ANTIw\<^sup>2 \<phi>" unfolding cond using L4 subset_char1 by blast
lemma nEXPN_ANTIw2_impl: "nEXPN \<phi> \<longrightarrow> ANTIw\<^sup>2 \<phi>" unfolding cond by (metis (full_types) compl_def meet_def subset_def)

(****************** Dual interrelations ****************)

lemma ADDIr_dual1: "ADDIr\<^sup>a \<phi> = MULTr\<^sup>b \<phi>\<^sup>d" unfolding cond subset_in_char subset_out_char by (smt (z3) BA_cp BA_deMorgan1 BA_dn op_dual_def setequ_ext)
lemma ADDIr_dual2: "ADDIr\<^sup>b \<phi> = MULTr\<^sup>a \<phi>\<^sup>d" unfolding cond subset_in_char subset_out_char by (smt (verit, ccfv_threshold) BA_cp BA_deMorgan1 BA_dn op_dual_def setequ_ext)
lemma ADDIr_dual:  "ADDIr \<phi> = MULTr \<phi>\<^sup>d" using ADDIr_char ADDIr_dual1 ADDIr_dual2 MULTr_char by blast

lemma nADDIr_dual1: "nADDIr\<^sup>a \<phi> = nMULTr\<^sup>b \<phi>\<^sup>d" unfolding cond subset_in_char subset_out_char by (smt (verit, del_insts) BA_cp BA_deMorgan1 BA_dn op_dual_def setequ_ext)
lemma nADDIr_dual2: "nADDIr\<^sup>b \<phi> = nMULTr\<^sup>a \<phi>\<^sup>d" by (smt (z3) BA_deMorgan1 BA_dn compl_def nADDIr_b_def nMULTr_a_def op_dual_def setequ_ext subset_in_def subset_out_def)
lemma nADDIr_dual: "nADDIr \<phi> = nMULTr \<phi>\<^sup>d" using nADDIr_char nADDIr_dual1 nADDIr_dual2 nMULTr_char by blast

(****************** Complement interrelations ****************)

lemma ADDIr_a_cmpl: "ADDIr\<^sup>a \<phi> = nADDIr\<^sup>a \<phi>\<^sup>c" unfolding cond by (smt (verit, del_insts) BA_deMorgan1 compl_def setequ_ext subset_out_def svfun_compl_def)
lemma ADDIr_b_cmpl: "ADDIr\<^sup>b \<phi> = nADDIr\<^sup>b \<phi>\<^sup>c" unfolding cond by (smt (verit, del_insts) BA_deMorgan1 compl_def setequ_ext subset_out_def svfun_compl_def)
lemma ADDIr_cmpl: "ADDIr \<phi> = nADDIr \<phi>\<^sup>c" by (simp add: ADDIr_a_cmpl ADDIr_b_cmpl ADDIr_char nADDIr_char)
lemma MULTr_a_cmpl: "MULTr\<^sup>a \<phi> = nMULTr\<^sup>a \<phi>\<^sup>c" unfolding cond by (smt (verit, del_insts) BA_deMorgan2 compl_def setequ_ext subset_in_def svfun_compl_def)
lemma MULTr_b_cmpl: "MULTr\<^sup>b \<phi> = nMULTr\<^sup>b \<phi>\<^sup>c" unfolding cond by (smt (verit, ccfv_threshold) BA_deMorgan2 compl_def setequ_ext subset_in_def svfun_compl_def)
lemma MULTr_cmpl: "MULTr \<phi> = nMULTr \<phi>\<^sup>c" by (simp add: MULTr_a_cmpl MULTr_b_cmpl MULTr_char nMULTr_char)

(****************** Fixed-point interrelations ****************)

lemma EXPN_fp:  "EXPN \<phi> = EXPN \<phi>\<^sup>f\<^sup>p" by (simp add: EXPN_def dimpl_def op_fixpoint_def subset_def)
lemma EXPN_fpc: "EXPN \<phi> = nEXPN \<phi>\<^sup>f\<^sup>p\<^sup>c" using EXPN_fp nEXPN_CNTR_compl by blast
lemma CNTR_fp:  "CNTR \<phi> = nCNTR \<phi>\<^sup>f\<^sup>p" by (metis EXPN_CNTR_dual1 EXPN_fp dual_compl_char2 dual_invol nCNTR_EXPN_compl ofp_comm_dc1 sfun_compl_invol)
lemma CNTR_fpc: "CNTR \<phi> = CNTR \<phi>\<^sup>f\<^sup>p\<^sup>c" by (metis CNTR_fp nCNTR_EXPN_compl ofp_comm_compl ofp_invol)

lemma nNORM_fp: "NORM \<phi> = nNORM \<phi>\<^sup>f\<^sup>p" by (metis NORM_def fixpoints_def fp_rel nNORM_def)
lemma NORM_fpc: "NORM \<phi> = NORM \<phi>\<^sup>f\<^sup>p\<^sup>c" by (simp add: NORM_def bottom_def ofp_fixpoint_compl_def sdiff_def)
lemma DNRM_fp:  "DNRM \<phi> = DNRM \<phi>\<^sup>f\<^sup>p" by (simp add: DNRM_def dimpl_def op_fixpoint_def top_def)
lemma DNRM_fpc: "DNRM \<phi> = nDNRM \<phi>\<^sup>f\<^sup>p\<^sup>c" using DNRM_fp nDNRM_DNRM_compl by blast

lemma ADDIr_a_fpc: "ADDIr\<^sup>a \<phi> = ADDIr\<^sup>a \<phi>\<^sup>f\<^sup>p\<^sup>c" unfolding cond subset_out_def by (simp add: join_def ofp_fixpoint_compl_def sdiff_def)
lemma ADDIr_a_fp: "ADDIr\<^sup>a \<phi> = nADDIr\<^sup>a \<phi>\<^sup>f\<^sup>p" by (metis ADDIr_a_cmpl ADDIr_a_fpc sfun_compl_invol)
lemma ADDIr_b_fpc: "ADDIr\<^sup>b \<phi> = ADDIr\<^sup>b \<phi>\<^sup>f\<^sup>p\<^sup>c" unfolding cond subset_out_def by (simp add: join_def ofp_fixpoint_compl_def sdiff_def)
lemma ADDIr_b_fp: "ADDIr\<^sup>b \<phi> = nADDIr\<^sup>b \<phi>\<^sup>f\<^sup>p" by (metis ADDIr_b_cmpl ADDIr_b_fpc sfun_compl_invol)

lemma MULTr_a_fp: "MULTr\<^sup>a \<phi> = MULTr\<^sup>a \<phi>\<^sup>f\<^sup>p" unfolding cond subset_in_def by (simp add: dimpl_def meet_def op_fixpoint_def)
lemma MULTr_a_fpc: "MULTr\<^sup>a \<phi> = nMULTr\<^sup>a \<phi>\<^sup>f\<^sup>p\<^sup>c" using MULTr_a_cmpl MULTr_a_fp by blast
lemma MULTr_b_fp: "MULTr\<^sup>b \<phi> = MULTr\<^sup>b \<phi>\<^sup>f\<^sup>p" unfolding cond subset_in_def by (simp add: dimpl_def meet_def op_fixpoint_def)
lemma MULTr_b_fpc: "MULTr\<^sup>b \<phi> = nMULTr\<^sup>b \<phi>\<^sup>f\<^sup>p\<^sup>c" using MULTr_b_cmpl MULTr_b_fp by blast

(****************** Relativized IDEM variants ****************)

definition IDEMr_a::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("IDEMr\<^sup>a")
  where "IDEMr\<^sup>a \<phi> \<equiv> \<forall>A. \<phi>(A \<^bold>\<or> \<phi> A) \<preceq>\<^sup>A (\<phi> A)"
definition IDEMr_b::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("IDEMr\<^sup>b")
  where "IDEMr\<^sup>b \<phi> \<equiv> \<forall>A. (\<phi> A) \<preceq>\<^sub>A \<phi>(A \<^bold>\<and> \<phi> A)"
declare IDEMr_a_def[cond] IDEMr_b_def[cond]

(****************** Relativized nIDEM variants ****************)

definition nIDEMr_a::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("nIDEMr\<^sup>a")
  where "nIDEMr\<^sup>a \<phi> \<equiv> \<forall>A. (\<phi> A) \<preceq>\<^sup>A \<phi>(A \<^bold>\<or> \<^bold>\<midarrow>(\<phi> A))"
definition nIDEMr_b::"('w \<sigma> \<Rightarrow> 'w \<sigma>) \<Rightarrow> bool" ("nIDEMr\<^sup>b")
  where "nIDEMr\<^sup>b \<phi> \<equiv> \<forall>A. \<phi>(A \<^bold>\<and> \<^bold>\<midarrow>(\<phi> A)) \<preceq>\<^sub>A (\<phi> A)"

declare nIDEMr_a_def[cond] nIDEMr_b_def[cond]

(****************** Complement interrelations ****************)

lemma IDEMr_a_cmpl: "IDEMr\<^sup>a \<phi> = nIDEMr\<^sup>a \<phi>\<^sup>c" unfolding cond subset_in_def subset_out_def by (metis compl_def sfun_compl_invol svfun_compl_def)
lemma IDEMr_b_cmpl: "IDEMr\<^sup>b \<phi> = nIDEMr\<^sup>b \<phi>\<^sup>c" unfolding cond subset_in_def subset_out_def by (metis compl_def sfun_compl_invol svfun_compl_def)

(****************** Dual interrelation ****************)

lemma IDEMr_dual: "IDEMr\<^sup>a \<phi> = IDEMr\<^sup>b \<phi>\<^sup>d" unfolding cond subset_in_def subset_out_def op_dual_def by (metis (mono_tags, opaque_lifting) BA_dn compl_def diff_char1 diff_char2 impl_char setequ_ext)
lemma nIDEMr_dual: "nIDEMr\<^sup>a \<phi> = nIDEMr\<^sup>b \<phi>\<^sup>d" by (metis IDEMr_dual IDEMr_a_cmpl IDEMr_b_cmpl dual_compl_char1 dual_compl_char2 sfun_compl_invol)

(****************** Fixed-point interrelations ****************)

lemma IDEMr_a_fp: "IDEMr\<^sup>a \<phi> = nIDEMr\<^sup>a \<phi>\<^sup>f\<^sup>p" proof -
  have l2r: "IDEMr\<^sup>a \<phi> \<longrightarrow> nIDEMr\<^sup>a \<phi>\<^sup>f\<^sup>p"
    unfolding cond subset_out_def op_fixpoint_def conn order apply simp (*by metis*) sorry (*fix proof reconstruction in kernel*)
  have r2l: "nIDEMr\<^sup>a \<phi>\<^sup>f\<^sup>p \<longrightarrow> IDEMr\<^sup>a \<phi>"
    unfolding cond subset_out_def op_fixpoint_def conn order apply simp (*by metis*) sorry (*fix proof reconstruction in kernel*)
  from l2r r2l show ?thesis by blast
qed
lemma IDEMr_a_fpc: "IDEMr\<^sup>a \<phi> = IDEMr\<^sup>a \<phi>\<^sup>f\<^sup>p\<^sup>c" using IDEMr_a_fp by (metis IDEMr_a_cmpl sfun_compl_invol)

lemma IDEMr_b_fp: "IDEMr\<^sup>b \<phi> = IDEMr\<^sup>b \<phi>\<^sup>f\<^sup>p" proof -
  have l2r: "IDEMr\<^sup>b \<phi> \<longrightarrow> IDEMr\<^sup>b \<phi>\<^sup>f\<^sup>p"
    unfolding cond subset_in_def op_fixpoint_def conn order apply simp (*by metis*) sorry (*fix proof reconstruction in kernel*)
  have r2l: "IDEMr\<^sup>b \<phi>\<^sup>f\<^sup>p \<longrightarrow> IDEMr\<^sup>b \<phi>"
    unfolding cond subset_in_def op_fixpoint_def conn order apply simp (*by metis*) sorry (*fix proof reconstruction in kernel*)
  from l2r r2l show ?thesis by blast
qed
lemma IDEMr_b_fpc: "IDEMr\<^sup>b \<phi> = nIDEMr\<^sup>b \<phi>\<^sup>f\<^sup>p\<^sup>c" using IDEMr_b_fp IDEMr_b_cmpl by blast

(***************************************************)
(*** Verifying original border axioms by Zarycki ***)
(***************************************************)

(*The original border condition B1' is equivalent to the conjuntion of nMULTr and CNTR*)
abbreviation "B1' \<phi> \<equiv> \<forall>A B. \<phi>(A \<^bold>\<and> B) \<approx> (A \<^bold>\<and> \<phi> B) \<^bold>\<or> (\<phi> A \<^bold>\<and> B)"

lemma "B1' \<phi> = (nMULTr \<phi> \<and> CNTR \<phi>)" proof -
  have l2ra: "B1' \<phi> \<longrightarrow> nMULTr \<phi>" unfolding cond by (smt (z3) join_def meet_def setequ_ext setequ_in_def)
  have l2rb: "B1' \<phi> \<longrightarrow> CNTR \<phi>" unfolding cond by (metis L2 L4 L5 L7 L9 setequ_ext)
  have r2l: "(nMULTr \<phi> \<and> CNTR \<phi>) \<longrightarrow> B1' \<phi>" unfolding cond by (smt (z3) L10 join_def meet_def setequ_def setequ_in_char)
  from l2ra l2rb r2l show ?thesis by blast
qed

(*Modulo conditions nMULTr and CNTR the border condition B4 is equivalent to nIDEMr\<^sup>b*)
abbreviation "B4 \<phi> \<equiv> \<forall>A. \<phi>(\<^bold>\<midarrow>\<phi>(\<^bold>\<midarrow>A)) \<preceq> A"

lemma "nMULTr \<phi> \<Longrightarrow> CNTR \<phi> \<Longrightarrow> B4 \<phi> = nIDEMr\<^sup>b \<phi>" proof -
  assume a1: "nMULTr \<phi>" and a2: "CNTR \<phi>"
  have l2r: "nMULTr\<^sup>b \<phi> \<Longrightarrow> B4 \<phi> \<longrightarrow> nIDEMr\<^sup>b \<phi>" unfolding cond subset_in_char subset_def by (metis BA_deMorgan1 BA_dn compl_def meet_def setequ_ext)
  have r2l: "nMULTr\<^sup>a \<phi> \<Longrightarrow> CNTR \<phi> \<Longrightarrow> nIDEMr\<^sup>b \<phi> \<longrightarrow> B4 \<phi>" unfolding cond by (smt (verit) compl_def join_def meet_def subset_def subset_in_def)
  from l2r r2l show ?thesis using a1 a2 nMULTr_char by blast
qed

end