theory Sepref_ICF_Bindings
imports Sepref_Tool
  Collections.Refine_Dflt_ICF
  "IICF/IICF"
begin
  subsection \<open>Miscellaneous\<close>
  lemma (in -) rev_append_hnr[param,sepref_import_param]:
    "(rev_append, rev_append) \<in> \<langle>A\<rangle>list_rel \<rightarrow> \<langle>A\<rangle>list_rel \<rightarrow> \<langle>A\<rangle>list_rel"
    unfolding rev_append_def by parametricity

  subsection \<open>Sets by List\<close>

  (* TODO: Move to Collections *)
  lemma lsr_finite[simp, intro]: "(l,s)\<in>\<langle>R\<rangle>list_set_rel \<Longrightarrow> finite s"
    by (auto simp: list_set_rel_def br_def)

  lemma it_to_sorted_list_triv:
    assumes "distinct l"
    shows "RETURN l \<le> it_to_sorted_list (\<lambda>_ _. True) (set l)"
    using assms unfolding it_to_sorted_list_def
    by refine_vcg auto

  lemma [sepref_gen_algo_rules]: "GEN_ALGO (return) (IS_TO_SORTED_LIST (\<lambda>_ _. True) (pure (\<langle>A\<rangle>list_set_rel)) (pure A))"
    unfolding GEN_ALGO_def IS_TO_SORTED_LIST_def
    apply (simp add: list_assn_pure_conv)
    apply rule
    apply rule
    apply (sep_auto simp: pure_def intro: it_to_sorted_list_triv simp: list_set_rel_def br_def)
    done

  lemma list_set_rel_compp:
    assumes "IS_LEFT_UNIQUE A" "IS_RIGHT_UNIQUE A"
    shows "\<langle>Id\<rangle>list_set_rel O \<langle>A\<rangle>set_rel = \<langle>A\<rangle>list_set_rel"
    unfolding list_set_rel_def
  proof (safe; clarsimp simp: in_br_conv)
    fix x z
    assume "(set x,z)\<in>\<langle>A\<rangle>set_rel" "distinct x"
    from obtain_list_from_setrel[OF \<open>IS_RIGHT_UNIQUE A\<close> this(1)] obtain zl where
      [simp]: "z = set zl" and X_ZL: "(x, zl) \<in> \<langle>A\<rangle>list_rel" .

    have "distinct zl"
      using param_distinct[OF assms, THEN fun_relD, OF X_ZL] \<open>distinct x\<close>
      by auto
    show "(x,z) \<in> \<langle>A\<rangle>list_rel O br set distinct"
      apply (rule relcompI[OF X_ZL])
      by (auto simp: in_br_conv \<open>distinct zl\<close>)
  next
    fix x y
    assume XY: "(x, y) \<in> \<langle>A\<rangle>list_rel" and "distinct y"

    have "distinct x"
      using param_distinct[OF assms, THEN fun_relD, OF XY] \<open>distinct y\<close>
      by auto

    show "(x, set y) \<in> br set distinct O \<langle>A\<rangle>set_rel"
      apply (rule relcompI[where b="set x"])
      subgoal by (auto simp: in_br_conv \<open>distinct x\<close>)
      subgoal by (rule param_set[OF \<open>IS_RIGHT_UNIQUE A\<close>, THEN fun_relD, OF XY])
      done
  qed

  lemma GEN_OP_EQ_Id: "GEN_OP (=) (=) (Id\<rightarrow>Id\<rightarrow>bool_rel)" by simp

  hide_const (open) Intf_Set.op_set_isEmpty Intf_Set.op_set_delete

  lemma autoref_import_set_unfolds:
    "{} = op_set_empty"
    "uncurry (RETURN oo (\<in>)) = uncurry (RETURN oo op_set_member)"
    "Intf_Set.op_set_isEmpty = IICF_Set.op_set_is_empty"
    "Intf_Set.op_set_delete = IICF_Set.op_set_delete"
    "insert = IICF_Set.op_set_insert"
    by (auto intro!: ext)

  context fixes A :: "'a \<Rightarrow> 'ai \<Rightarrow> assn" begin
    private lemma APA: "\<lbrakk>PROP Q; CONSTRAINT is_pure A\<rbrakk> \<Longrightarrow> PROP Q" .
    private lemma APAru: "\<lbrakk>PROP Q; CONSTRAINT (IS_PURE IS_RIGHT_UNIQUE) A\<rbrakk> \<Longrightarrow> PROP Q" .
    private lemma APAlu: "\<lbrakk>PROP Q; CONSTRAINT (IS_PURE IS_LEFT_UNIQUE) A\<rbrakk> \<Longrightarrow> PROP Q" .
    private lemma APAbu: "\<lbrakk>PROP Q; CONSTRAINT (IS_PURE IS_LEFT_UNIQUE) A; CONSTRAINT (IS_PURE IS_RIGHT_UNIQUE) A\<rbrakk> \<Longrightarrow> PROP Q" .
    definition "list_set_assn = pure (\<langle>Id\<rangle>list_set_rel O \<langle>the_pure A\<rangle>set_rel)"
    context
      notes [fcomp_norm_unfold] = list_set_assn_def[symmetric]
      notes [simp] = IS_LEFT_UNIQUE_def
    begin

      lemmas hnr_op_ls_empty = list_set_autoref_empty[of Id, sepref_param, unfolded autoref_import_set_unfolds,
        FCOMP op_set_empty.fref[of "the_pure A"]]
      lemmas hnr_mop_ls_empty = hnr_op_ls_empty[FCOMP mk_mop_rl0_np[OF mop_set_empty_alt]]

      definition [simp]: "op_ls_empty = op_set_empty"
      sepref_register op_ls_empty

      lemmas hnr_op_ls_is_empty[sepref_fr_rules] = list_set_autoref_isEmpty[of Id, sepref_param, THEN APA, unfolded autoref_import_set_unfolds,
        FCOMP op_set_is_empty.fref[of "the_pure A"]]
      lemmas hnr_mop_ls_is_empty[sepref_fr_rules] = hnr_op_ls_is_empty[FCOMP mk_mop_rl1_np[OF mop_set_is_empty_alt]]

      lemmas hnr_op_ls_member[sepref_fr_rules] = list_set_autoref_member[OF GEN_OP_EQ_Id, sepref_param, THEN APAlu, unfolded autoref_import_set_unfolds,
        FCOMP op_set_member.fref[of "the_pure A"]]
      lemmas hnr_mop_ls_member[sepref_fr_rules] = hnr_op_ls_member[FCOMP mk_mop_rl2_np[OF mop_set_member_alt]]

      lemmas hnr_op_ls_insert[sepref_fr_rules] = list_set_autoref_insert[OF GEN_OP_EQ_Id, sepref_param, THEN APAru, unfolded autoref_import_set_unfolds,
        FCOMP op_set_insert.fref[of "the_pure A"]]
      lemmas hnr_mop_ls_insert[sepref_fr_rules] = hnr_op_ls_insert[FCOMP mk_mop_rl2_np[OF mop_set_insert_alt]]

      lemmas hnr_op_ls_delete[sepref_fr_rules] = list_set_autoref_delete[OF GEN_OP_EQ_Id, sepref_param, THEN APAbu, unfolded autoref_import_set_unfolds,
        FCOMP op_set_delete.fref[of "the_pure A"]]
      lemmas hnr_mop_ls_delete[sepref_fr_rules] = hnr_op_ls_delete[FCOMP mk_mop_rl2_np[OF mop_set_delete_alt]]

      text \<open>Adapting this optimization from Autoref. \<close>
      sepref_decl_op set_insert_dj: "insert" :: "[\<lambda>(x,s). x\<notin>s]\<^sub>f K \<times>\<^sub>r \<langle>K\<rangle>set_rel \<rightarrow> \<langle>K\<rangle>set_rel"
        where "IS_RIGHT_UNIQUE K" "IS_LEFT_UNIQUE K" .

      lemma fold_set_insert_dj: "Set.insert = op_set_insert_dj" by simp

      lemma ls_insert_dj_hnr_aux:
        "(uncurry (return oo Cons), uncurry mop_set_insert_dj) \<in> (pure Id)\<^sup>k *\<^sub>a (pure (\<langle>Id\<rangle>list_set_rel))\<^sup>k \<rightarrow>\<^sub>a pure (\<langle>Id\<rangle>list_set_rel)"
        using list_set_autoref_insert_dj[where R=Id,param_fo]
        apply (sep_auto intro!: hfrefI hn_refineI simp: pure_def refine_pw_simps eintros del: exI)
        apply force
        done

      lemmas ls_insert_dj_hnr[sepref_fr_rules] = ls_insert_dj_hnr_aux[THEN APAbu, FCOMP mop_set_insert_dj.fref[of "the_pure A"]]
      lemmas ls_insert_dj_hnr_mop[sepref_fr_rules]
        = ls_insert_dj_hnr[FCOMP mk_op_rl2[OF mop_set_insert_dj_alt]]

      private lemma hd_in_set_conv: "hd l \<in> set l \<longleftrightarrow> l\<noteq>[]" by auto

      lemma ls_pick_hnr_aux: "(return o hd, mop_set_pick) \<in> (pure (\<langle>Id\<rangle>list_set_rel))\<^sup>k \<rightarrow>\<^sub>a id_assn"
        apply (sep_auto
          intro!: hfrefI hn_refineI
          simp: pure_def IS_PURE_def IS_ID_def list_set_rel_def refine_pw_simps
          eintros del: exI)
        apply (auto simp: in_br_conv hd_in_set_conv)
        done

      lemmas ls_pick_hnr[sepref_fr_rules] = ls_pick_hnr_aux[THEN APA,FCOMP mop_set_pick.fref[of "the_pure A"]]
      lemma ls_pick_hnr_mop[sepref_fr_rules]: "CONSTRAINT is_pure A \<Longrightarrow> (return \<circ> hd, op_set_pick) \<in> [\<lambda>s. s\<noteq>{}]\<^sub>a list_set_assn\<^sup>k \<rightarrow> A"
        using ls_pick_hnr
        by (simp add: hfref_to_ASSERT_conv mop_set_pick_alt[abs_def])

    end
  end

  interpretation ls: set_custom_empty "return []" op_ls_empty
    by unfold_locales simp
  lemmas [sepref_fr_rules] = hnr_op_ls_empty[folded op_ls_empty_def]

end


(*  File:       Elect_Composition.thy
    Copyright   2021  Karlsruhe Institute of Technology (KIT)
*)
\<^marker>\<open>creator "Karsten Diekhoff, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Jonas Kraemer, Karlsruhe Institute of Technology (KIT)"\<close>
\<^marker>\<open>contributor "Michael Kirsten, Karlsruhe Institute of Technology (KIT)"\<close>

section \<open>Elect Composition\<close>

theory Elect_Composition
  imports "Basic_Modules/Elect_Module"
          Sequential_Composition
begin

text
\<open>The elect composition sequences an electoral module and the elect
module. It finalizes the module's decision as it simply elects all their
non-rejected alternatives. Thereby, any such elect-composed module induces
a proper voting rule in the social choice sense, as all alternatives are either
rejected or elected.\<close>

subsection \<open>Definition\<close>

fun elector :: "'a Electoral_Module \<Rightarrow> 'a Electoral_Module" where
  "elector m = (m \<triangleright> elect_module)"

subsection \<open>Soundness\<close>

theorem elector_sound[simp]:
  assumes module_m: "electoral_module m"
  shows "electoral_module (elector m)"
  by (simp add: module_m)

subsection \<open>Electing\<close>

theorem elector_electing[simp]:
  assumes
    module_m: "electoral_module m" and
    non_block_m: "non_blocking m"
  shows "electing (elector m)"
proof -
  (*obtain
    AA :: "'a Electoral_Module \<Rightarrow> 'a set" and
    rrs :: "'a Electoral_Module \<Rightarrow> 'a Profile" and
    vvs :: "'a Electoral_Module \<Rightarrow> 'a Pair_Vectors" where
    f1:
    "\<forall>f.
      (electing f \<or>
        {} = elect f (AA f) (rrs f) (vvs f) \<and> profile (AA f) (rrs f) \<and>
        vector_pair (AA f) (rrs f) (vvs f) \<and>
            finite (AA f) \<and> {} \<noteq> AA f \<or>
        \<not> electoral_module f) \<and>
            ((\<forall>A rs vs. {} \<noteq> elect f A rs vs \<or> \<not> profile A rs \<or> vector_pair A rs vs \<or>
                infinite A \<or> {} = A) \<and>
            electoral_module f \<or>
        \<not> electing f)"
    using electing_def sorry*)
    (*by metis*)
  have non_block:
    "non_blocking
      (elect_module::'a set \<Rightarrow> _ Profile \<Rightarrow> _ Pair_Vectors \<Rightarrow> _ Result)"
    by (simp add: electing_imp_non_blocking)
  thus ?thesis
    using Diff_empty elect_module.elims elector.simps non_block_m
          non_blocking_def reject_not_elec_or_def seq_comp_defers_def_set
          seq_comp_presv_non_blocking snd_conv elect_mod_sound fst_conv
          elect_module.simps elector_sound module_m disjoint3.cases
          empty_iff ex_in_conv seq_comp_def_set_trans
    by (smt (z3) electing_def)
  (*proof -
    obtain
      AAa :: "'a Electoral_Module \<Rightarrow> 'a set" and
      rrsa :: "'a Electoral_Module \<Rightarrow> 'a Profile" and
      vvsa :: "'a Electoral_Module \<Rightarrow> 'a Pair_Vectors" where
      f1:
      "\<forall>f.
        (electing f \<or>
          {} = elect f (AAa f) (rrsa f) (vvsa f) \<and> profile (AAa f) (rrsa f) \<and>
              vector_pair (AAa f) (rrsa f) (vvsa f) \<and> finite (AAa f) \<and> {} \<noteq> AAa f \<or>
        \<not> electoral_module f) \<and> ((\<forall>A rs vs. {} \<noteq> elect f A rs vs \<or>
        \<not> profile A rs \<or> \<not> vector_pair A rs vs \<or> infinite A \<or> {} = A) \<and> electoral_module f \<or>
        \<not> electing f)"
      using electing_def sorry
      (*by metis*)
    obtain
      AAb :: "'a Result \<Rightarrow> 'a set" and
      AAc :: "'a Result \<Rightarrow> 'a set" and
      AAd :: "'a Result \<Rightarrow> 'a set" where
      f2:
      "\<forall>p. (AAb p, AAc p, AAd p) = p"
      using disjoint3.cases
      by (metis (no_types))
    have f3:
      "electoral_module (elector m)"
      using elector_sound module_m
      by simp
    have f4:
      "\<forall>p. (elect_r p, AAc p, AAd p) = p"
      using f2
      by simp
    have
      "finite (AAa (elector m)) \<and>
        profile (AAa (elector m)) (rrsa (elector m)) \<and>
        vector_pair (AAa (elector m)) (rrsa (elector m)) (vvsa (elector m)) \<and>
        {} = elect (elector m) (AAa (elector m)) (rrsa (elector m)) (vvsa (elector m)) \<and>
        {} = AAd (elector m (AAa (elector m)) (rrsa (elector m)) (vvsa (elector m))) \<and>
        reject (elector m) (AAa (elector m)) (rrsa (elector m)) (vvsa (elector m)) =
          AAc (elector m (AAa (elector m)) (rrsa (elector m)) (vvsa (elector m))) \<longrightarrow>
              electing (elector m)"
      using f2 f1 Diff_empty elector.simps non_block_m snd_conv
            non_blocking_def reject_not_elec_or_def non_block
            seq_comp_presv_non_blocking
      (*by metis*) sorry
    moreover
    {
      assume
        "{} \<noteq> AAd (elector m (AAa (elector m)) (rrsa (elector m)) (vvsa (elector m)))"
      hence
        "\<not> profile (AAa (elector m)) (rrsa (elector m)) \<or>
          infinite (AAa (elector m))"
        using f4
        by simp
    }
    ultimately show ?thesis
      using f4 f3 f1 fst_conv snd_conv
      by metis
  qed*)
qed

subsection \<open>Composition Rule\<close>

(*If m is defer-Condorcet-consistent, then elector(m) is Condorcet consistent.*)
lemma dcc_imp_cc_elector:
  assumes dcc: "defer_condorcet_consistency m"
  shows "condorcet_consistency (elector m)"
proof (unfold defer_condorcet_consistency_def
              condorcet_consistency_def, auto)
  show "electoral_module (m \<triangleright> elect_module)"
    using dcc defer_condorcet_consistency_def
          elect_mod_sound seq_comp_sound
    by metis
next
  show
    "\<And>A p w x vs.
       finite A \<Longrightarrow> profile A p \<Longrightarrow> vector_pair A vs \<Longrightarrow> w \<in> A \<Longrightarrow>
         \<forall>x\<in>A - {w}. card {i. i < length p \<and> (w, x) \<in> (p!i)} <
            card {i. i < length p \<and> (x, w) \<in> (p!i)} \<Longrightarrow>
        x \<in> elect m A p vs \<Longrightarrow> x \<in> A"
  proof -
    fix
      A :: "'a set" and
      p :: "'a Profile" and
      vs :: "'a Pair_Vectors" and
      w :: "'a" and
      x :: "'a"
    assume
      finite: "finite A" and
      prof_A: "profile A p" and
      vec_A: "vector_pair A vs"
    show
      "\<forall>y\<in>A - {w}.
          card {i. i < length p \<and> (w, y) \<in> (p!i)} <
            card {i. i < length p \<and> (y, w) \<in> (p!i)} \<Longrightarrow>
             x \<in> elect m A p vs \<Longrightarrow> x \<in> A"
      using dcc defer_condorcet_consistency_def
            elect_in_alts subset_eq finite prof_A vec_A
      by metis
  qed
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs:: "'a Pair_Vectors" and
    w :: "'a" and
    x :: "'a" and
    xa :: "'a"
  assume
    finite: "finite A" and
    prof_A: "profile A p" and
    vec_A: "vector_pair A vs" and
    w_in_A: "w \<in> A" and
    1: "x \<in> elect m A p vs" and
    2: "\<forall>y\<in>A - {w}.
          card {i. i < length p \<and> (w, y) \<in> (p!i)} <
            card {i. i < length p \<and> (y, w) \<in> (p!i)}"
  have "condorcet_winner A p w"
    using finite prof_A w_in_A "2"
    by simp
  thus "xa = x"
    using condorcet_winner.simps dcc fst_conv insert_Diff "1"
          defer_condorcet_consistency_def insert_not_empty vec_A
    by (smt (verit))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs:: "'a Pair_Vectors" and
    w :: "'a" and
    x :: "'a"
  assume
    finite: "finite A" and
    prof_A: "profile A p" and
    vec_A: "vector_pair A vs" and
    w_in_A: "w \<in> A" and
    0: "\<forall>y\<in>A - {w}.
          card {i. i < length p \<and> (w, y) \<in> (p!i)} <
            card {i. i < length p \<and> (y, w) \<in> (p!i)}" and
    1: "x \<in> defer m A p vs"
  have "condorcet_winner A p w"
    using finite prof_A w_in_A "0"
    by simp
  thus "x \<in> A"
    using "0" "1" condorcet_winner.simps dcc defer_in_alts
          defer_condorcet_consistency_def order_trans
          subset_Compl_singleton vec_A
    by (smt (verit))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs:: "'a Pair_Vectors" and
    w :: "'a" and
    x :: "'a" and
    xa :: "'a"
  assume
    finite: "finite A" and
    prof_A: "profile A p" and
    vec_A: "vector_pair A vs" and
    w_in_A: "w \<in> A" and
    1: "x \<in> defer m A p vs" and
    xa_in_A: "xa \<in> A" and
    2: "\<forall>y\<in>A - {w}.
          card {i. i < length p \<and> (w, y) \<in> (p!i)} <
            card {i. i < length p \<and> (y, w) \<in> (p!i)}" and
    3: "\<not> card {i. i < length p \<and> (x, xa) \<in> (p!i)} <
            card {i. i < length p \<and> (xa, x) \<in> (p!i)}"
  have "condorcet_winner A p w"
    using finite prof_A w_in_A "2"
    by simp
  thus "xa = x"
    using "1" "2" condorcet_winner.simps dcc empty_iff xa_in_A
          defer_condorcet_consistency_def "3" DiffI
          cond_winner_unique3 insert_iff prod.sel(2) vec_A
    by (metis (no_types, lifting))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs:: "'a Pair_Vectors" and
    w :: "'a" and
    x :: "'a"
  assume
    finite: "finite A" and
    prof_A: "profile A p" and
    vec_A: "vector_pair A vs" and
    w_in_A: "w \<in> A" and
    x_in_A: "x \<in> A" and
    1: "x \<notin> defer m A p vs" and
    2: "\<forall>y\<in>A - {w}.
          card {i. i < length p \<and> (w, y) \<in> (p!i)} <
            card {i. i < length p \<and> (y, w) \<in> (p!i)}" and
    3: "\<forall>y\<in>A - {x}.
          card {i. i < length p \<and> (x, y) \<in> (p!i)} <
            card {i. i < length p \<and> (y, x) \<in> (p!i)}"
  have "condorcet_winner A p w"
    using finite prof_A w_in_A "2"
    by simp
  also have "condorcet_winner A p x"
    using finite prof_A x_in_A "3"
    by simp
  ultimately show "x \<in> elect m A p vs"
    using "1" condorcet_winner.simps dcc
          defer_condorcet_consistency_def
          cond_winner_unique3 insert_iff eq_snd_iff vec_A
    by (smt (verit, del_insts))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs:: "'a Pair_Vectors" and
    w :: "'a" and
    x :: "'a"
  assume
    finite: "finite A" and
    prof_A: "profile A p" and
    vec_A: "vector_pair A vs" and
    w_in_A: "w \<in> A" and
    1: "x \<in> reject m A p vs" and
    2: "\<forall>y\<in>A - {w}.
          card {i. i < length p \<and> (w, y) \<in> (p!i)} <
            card {i. i < length p \<and> (y, w) \<in> (p!i)}"
  have "condorcet_winner A p w"
    using finite prof_A w_in_A "2"
    by simp
  thus "x \<in> A"
    using "1" dcc defer_condorcet_consistency_def finite
          prof_A reject_in_alts subsetD vec_A
    by metis
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs:: "'a Pair_Vectors" and
    w :: "'a" and
    x :: "'a"
  assume
    finite: "finite A" and
    prof_A: "profile A p" and
    vec_A: "vector_pair A vs" and
    w_in_A: "w \<in> A" and
    0: "x \<in> reject m A p vs" and
    1: "x \<in> elect m A p vs" and
    2: "\<forall>y\<in>A - {w}.
          card {i. i < length p \<and> (w, y) \<in> (p!i)} <
            card {i. i < length p \<and> (y, w) \<in> (p!i)}"
  have "condorcet_winner A p w"
    using finite prof_A w_in_A "2"
    by simp
  thus "False"
    using "0" "1" condorcet_winner.simps dcc IntI empty_iff
          defer_condorcet_consistency_def result_disj vec_A
    by (metis (no_types, hide_lams))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs:: "'a Pair_Vectors" and
    w :: "'a" and
    x :: "'a"
  assume
    finite: "finite A" and
    prof_A: "profile A p" and
    vec_A: "vector_pair A vs" and
    w_in_A: "w \<in> A" and
    0: "x \<in> reject m A p vs" and
    1: "x \<in> defer m A p vs" and
    2: "\<forall>y\<in>A - {w}.
          card {i. i < length p \<and> (w, y) \<in> (p!i)} <
            card {i. i < length p \<and> (y, w) \<in> (p!i)}"
  have "condorcet_winner A p w"
    using finite prof_A w_in_A "2"
    by simp
  thus "False"
    using "0" "1" dcc defer_condorcet_consistency_def IntI
          Diff_empty Diff_iff finite prof_A result_disj vec_A
    by (metis (no_types, hide_lams))
next
  fix
    A :: "'a set" and
    p :: "'a Profile" and
    vs:: "'a Pair_Vectors" and
    w :: "'a" and
    x :: "'a"
  assume
    finite: "finite A" and
    prof_A: "profile A p" and
    vec_A: "vector_pair A vs" and
    w_in_A: "w \<in> A" and
    x_in_A: "x \<in> A" and
    0: "x \<notin> reject m A p vs" and
    1: "x \<notin> defer m A p vs" and
    2: "\<forall>y\<in>A - {w}.
          card {i. i < length p \<and> (w, y) \<in> (p!i)} <
            card {i. i < length p \<and> (y, w) \<in> (p!i)}"
  have "condorcet_winner A p w"
    using finite prof_A w_in_A "2"
    by simp
  thus "x \<in> elect m A p vs"
    using "0" "1" condorcet_winner.simps dcc x_in_A vec_A
          defer_condorcet_consistency_def electoral_mod_defer_elem
    by (smt (verit))
qed

end


(*  Title:       Jive Data and Store Model
    Author:      Norbert Schirmer <schirmer at informatik.tu-muenchen.de>, 2003
    Maintainer:  Nicole Rauch <rauch at informatik.uni-kl.de>
    License:     LGPL
*)

section \<open>Store Properties\<close>

theory StoreProperties
imports Store
begin

text \<open>This theory formalizes advanced concepts and properties of stores.\<close>

subsection \<open>Reachability of a Location from a Reference\<close>

text \<open>For a given store, the function \<open>reachS\<close> yields the set of all pairs
$(l,v)$ where $l$ is a location that is reachable from the value $v$ (which must be a reference)
in the given store.
The predicate \<open>reach\<close> decides whether a location is reachable from a value in a store.
\<close>

inductive
  reach :: "Store \<Rightarrow> Location \<Rightarrow> Value \<Rightarrow> bool"
    ("_\<turnstile> _ reachable'_from _" [91,91,91]90)
  for s :: Store
where
  Immediate: "ref l \<noteq> nullV \<Longrightarrow> s\<turnstile> l reachable_from (ref l)"
| Indirect: "\<lbrakk>s\<turnstile> l reachable_from (s@@k); ref k \<noteq> nullV\<rbrakk>
             \<Longrightarrow> s\<turnstile> l reachable_from (ref k)"

text \<open>Note that we explicitly exclude \<open>nullV\<close> as legal reference
for reachability.
Keep in mind that static fields are not associated to any object,
therefore \<open>ref\<close> yields \<open>nullV\<close> if invoked on static fields
(see the
definition of the function \<open>ref\<close>, Sect. \ref{ref_def}).
Reachability only describes the locations directly
reachable from the object or array by following the pointers and should not include
the static fields if we encounter a \<open>nullV\<close> reference in the pointer
chain.\<close>

text \<open>We formalize some properties of reachability.
Especially, Lemma 3.2 as given in \<^cite>\<open>\<open>p. 53\<close> in "Poetzsch-Heffter97specification"\<close> is proven.\<close>

lemma unreachable_Null:
  assumes reach: "s\<turnstile> l reachable_from x" shows "x\<noteq>nullV"
  using reach by (induct) auto

corollary unreachable_Null_simp [simp]:
  "\<not> s\<turnstile> l reachable_from nullV"
  by (iprover dest: unreachable_Null)

corollary unreachable_NullE [elim]:
  "s\<turnstile> l reachable_from nullV \<Longrightarrow> P"
  by (simp)

lemma reachObjLoc [simp,intro]:
  "C=cls cf \<Longrightarrow> s\<turnstile> objLoc cf a reachable_from objV C a"
  by (iprover intro: reach.Immediate [of "objLoc cf a",simplified])

lemma reachArrLoc [simp,intro]: "s\<turnstile> arrLoc T a i reachable_from arrV T a"
  by (rule reach.Immediate [of "arrLoc T a i",simplified])

lemma reachArrLen [simp,intro]: "s\<turnstile> arrLenLoc T a reachable_from arrV T a"
  by (rule reach.Immediate [of "arrLenLoc T a",simplified])

lemma unreachStatic [simp]: "\<not> s\<turnstile> staticLoc f reachable_from x"
proof -
  {
    fix y assume "s\<turnstile> y reachable_from x" "y=staticLoc f"
    then have False
      by induct auto
  }
  thus ?thesis
    by auto
qed

lemma unreachStaticE [elim]: "s\<turnstile> staticLoc f reachable_from x \<Longrightarrow> P"
  by (simp add: unreachStatic)

lemma reachable_from_ArrLoc_impl_Arr [simp,intro]:
  assumes reach_loc: "s\<turnstile> l reachable_from (s@@arrLoc T a i)"
  shows "s\<turnstile> l reachable_from (arrV T a)"
  using reach.Indirect [OF reach_loc]
  by simp

lemma reachable_from_ObjLoc_impl_Obj [simp,intro]:
  assumes reach_loc: "s\<turnstile> l reachable_from (s@@objLoc cf a)"
  assumes C: "C=cls cf"
  shows "s\<turnstile> l reachable_from (objV C a)"
  using C reach.Indirect [OF reach_loc]
  by simp

text \<open>Lemma 3.2 (i)\<close>
lemma reach_update [simp]:
  assumes unreachable_l_x: "\<not> s\<turnstile> l reachable_from x"
  shows "s\<langle>l:=y\<rangle>\<turnstile> k reachable_from  x = s\<turnstile> k reachable_from x"
proof
  assume "s\<turnstile> k reachable_from x"
  from this unreachable_l_x
  show "s\<langle>l := y\<rangle>\<turnstile> k reachable_from x"
  proof (induct)
    case (Immediate k)
    have "ref k \<noteq> nullV" by fact
    then show "s\<langle>l := y\<rangle>\<turnstile> k reachable_from (ref k)"
      by (rule reach.Immediate)
  next
    case (Indirect k m)
    have hyp: "\<not> s\<turnstile> l reachable_from (s@@m)
               \<Longrightarrow> s\<langle>l:=y\<rangle> \<turnstile> k reachable_from (s@@m)" by fact
    have "ref m \<noteq> nullV" and "\<not> s\<turnstile> l reachable_from (ref m)" by fact+
    hence "l\<noteq>m" "\<not> s\<turnstile> l reachable_from (s@@m)"
      by (auto intro: reach.intros)
    with hyp have "s\<langle>l := y\<rangle> \<turnstile> k reachable_from (s\<langle>l := y\<rangle>@@m)"
      by simp
    then show "s\<langle>l := y\<rangle>\<turnstile> k reachable_from (ref m)"
      by (rule reach.Indirect) (rule Indirect.hyps)
  qed
next
  assume "s\<langle>l := y\<rangle>\<turnstile> k reachable_from x"
  from this unreachable_l_x
  show "s\<turnstile> k reachable_from x"
  proof (induct)
    case (Immediate k)
    have "ref k \<noteq> nullV" by fact
    then show "s \<turnstile> k reachable_from (ref k)"
      by (rule reach.Immediate)
  next
    case (Indirect k m)
    with Indirect.hyps
    have hyp: "\<not> s\<turnstile> l reachable_from (s\<langle>l := y\<rangle>@@m)
               \<Longrightarrow> s\<turnstile> k reachable_from (s\<langle>l := y\<rangle>@@m)" by simp
    have "ref m \<noteq> nullV" and "\<not> s\<turnstile> l reachable_from (ref m)" by fact+
    hence "l\<noteq>m" "\<not> s \<turnstile> l reachable_from (s@@m)"
      by (auto intro: reach.intros)
    with hyp have "s \<turnstile> k reachable_from (s@@m)"
      by simp
    thus "s\<turnstile> k reachable_from (ref m)"
      by (rule reach.Indirect) (rule Indirect.hyps)
  qed
qed

text \<open>Lemma 3.2 (ii)\<close>
lemma reach2:
  "\<not> s\<turnstile> l reachable_from x \<Longrightarrow> \<not> s\<langle>l:=y\<rangle>\<turnstile> l reachable_from x"
  by (simp)

text \<open>Lemma 3.2 (iv)\<close>
lemma reach4: "\<not> s \<turnstile> l reachable_from (ref k) \<Longrightarrow> k \<noteq> l \<or> (ref k) = nullV"
  by (auto intro: reach.intros)

lemma reachable_isRef:
  assumes reach: "s\<turnstile>l reachable_from x"
  shows "isRefV x"
  using reach
proof (induct)
  case (Immediate l)
  show "isRefV (ref l)"
    by (cases l) simp_all
next
  case (Indirect l k)
  show "isRefV (ref k)"
    by (cases k) simp_all
qed

lemma val_ArrLen_IntgT: "isArrLenLoc l \<Longrightarrow> typeof (s@@l) = IntgT"
proof -
  assume isArrLen: "isArrLenLoc l"
  have T: "typeof (s@@l) \<le> ltype l"
    by (simp)
  also from isArrLen have I: "ltype l = IntgT"
    by (cases l) simp_all
  finally show ?thesis
    by (auto elim: rtranclE simp add: le_Javatype_def subtype_defs)
qed

lemma access_alloc' [simp]:
  assumes no_arr_len: "\<not> isArrLenLoc l"
  shows "s\<langle>t\<rangle>@@l = s@@l"
proof -
  from no_arr_len
  have "isNewArr t \<longrightarrow> l \<noteq> arr_len (new s t)"
    by (cases t) (auto simp add: new_def isArrLenLoc_def split: Location.splits)
  thus ?thesis
    by (rule access_alloc)
qed

text \<open>Lemma 3.2 (v)\<close>
lemma reach_alloc [simp]: "s\<langle>t\<rangle>\<turnstile> l reachable_from x = s\<turnstile> l reachable_from x"
proof
  assume "s\<langle>t\<rangle>\<turnstile> l reachable_from x"
  thus "s\<turnstile> l reachable_from x"
  proof (induct)
    case (Immediate l)
    thus "s\<turnstile> l reachable_from ref l"
      by (rule reach.intros)
  next
    case (Indirect l k)
    have reach_k: "s\<turnstile> l reachable_from (s\<langle>t\<rangle>@@k)" by fact
    moreover
    have "s\<langle>t\<rangle>@@k = s@@k"
    proof -
      from reach_k have isRef: "isRefV (s\<langle>t\<rangle>@@k)"
        by (rule reachable_isRef)
      have "\<not> isArrLenLoc k"
      proof (rule ccontr,simp)
        assume "isArrLenLoc k"
        then have "typeof (s\<langle>t\<rangle>@@k) = IntgT"
          by (rule val_ArrLen_IntgT)
        with isRef
        show "False"
          by (cases "(s\<langle>t\<rangle>@@k)") simp_all
      qed
      thus ?thesis
        by (rule access_alloc')
    qed
    ultimately have "s\<turnstile> l reachable_from (s@@k)"
      by simp
    thus "s\<turnstile> l reachable_from ref k"
      by (rule reach.intros) (rule Indirect.hyps)
  qed
next
  assume "s\<turnstile> l reachable_from x"
  thus "s\<langle>t\<rangle>\<turnstile> l reachable_from x"
  proof (induct)
    case (Immediate l)
    thus "s\<langle>t\<rangle>\<turnstile> l reachable_from ref l"
      by (rule reach.intros)
  next
    case (Indirect l k)
    have reach_k: "s\<langle>t\<rangle>\<turnstile> l reachable_from (s@@k)" by fact
    moreover
    have "s\<langle>t\<rangle>@@k = s@@k"
    proof -
      from reach_k have isRef: "isRefV (s@@k)"
        by (rule reachable_isRef)
      have "\<not> isArrLenLoc k"
      proof (rule ccontr,simp)
        assume "isArrLenLoc k"
        then have "typeof (s@@k) = IntgT"
          by (rule val_ArrLen_IntgT)
        with isRef
        show "False"
          by (cases "(s@@k)") simp_all
      qed
      thus ?thesis
        by (rule access_alloc')
    qed
    ultimately have "s\<langle>t\<rangle>\<turnstile> l reachable_from (s\<langle>t\<rangle>@@k)"
      by simp
    thus "s\<langle>t\<rangle>\<turnstile> l reachable_from ref k"
      by (rule reach.intros) (rule Indirect.hyps)
  qed
qed

text \<open>Lemma 3.2 (vi)\<close>
lemma reach6: "isprimitive(typeof x) \<Longrightarrow> \<not> s \<turnstile> l reachable_from x"
proof
  assume prim: "isprimitive(typeof x)"
  assume "s \<turnstile> l reachable_from x"
  hence "isRefV x"
    by (rule reachable_isRef)
  with prim show False
    by (cases x) simp_all
qed

text \<open>Lemma 3.2 (iii)\<close>
lemma reach3:
  assumes k_y: "\<not> s\<turnstile> k reachable_from y"
  assumes k_x: "\<not> s\<turnstile> k reachable_from x"
  shows "\<not> s\<langle>l:=y\<rangle>\<turnstile> k reachable_from x"
proof
  assume "s\<langle>l:=y\<rangle>\<turnstile> k reachable_from x"
  from this k_y k_x
  show False
  proof (induct)
    case (Immediate l)
    have "\<not> s\<turnstile> l reachable_from ref l" and "ref l \<noteq> nullV" by fact+
    thus False
      by (iprover intro: reach.intros)
  next
    case (Indirect m k)
    have k_not_Null: "ref k \<noteq> nullV" by fact
    have not_m_y: "\<not> s\<turnstile> m reachable_from y" by fact
    have not_m_k: "\<not> s\<turnstile> m reachable_from ref k" by fact
    have hyp: "\<lbrakk>\<not> s\<turnstile> m reachable_from y; \<not> s\<turnstile> m reachable_from (s\<langle>l := y\<rangle>@@k)\<rbrakk>
               \<Longrightarrow> False" by fact
    have m_upd_k: "s\<langle>l := y\<rangle>\<turnstile> m reachable_from (s\<langle>l := y\<rangle>@@k)" by fact
    show False
    proof (cases "l=k")
      case False
      then have "s\<langle>l := y\<rangle>@@k = s@@k" by simp
      moreover
      from not_m_k k_not_Null have "\<not> s\<turnstile> m reachable_from (s@@k)"
        by (iprover intro: reach.intros)
      ultimately show False
        using not_m_y hyp by simp
    next
      case True note eq_l_k = this
      show ?thesis
      proof (cases "alive (ref l) s \<and> alive y s \<and> typeof y \<le> ltype l")
        case True
        with eq_l_k have "s\<langle>l := y\<rangle>@@k = y"
          by simp
        with not_m_y hyp show False by simp
      next
        case False
        hence "s\<langle>l := y\<rangle> = s"
          by auto
        moreover
        from not_m_k k_not_Null have "\<not> s\<turnstile> m reachable_from (s@@k)"
          by (iprover intro: reach.intros)
        ultimately show False
          using not_m_y hyp by simp
      qed
    qed
  qed
qed

text \<open>Lemma 3.2 (vii).\<close>

lemma unreachable_from_init [simp,intro]: "\<not> s\<turnstile> l reachable_from (init T)"
  using reach6 by (cases T) simp_all

lemma ref_reach_unalive:
  assumes unalive_x:"\<not> alive x s"
  assumes l_x: "s\<turnstile> l reachable_from x"
  shows "x = ref l"
using l_x unalive_x
proof induct
  case (Immediate l)
  show "ref l = ref l"
    by simp
next
  case (Indirect l k)
  have "ref k \<noteq> nullV" by fact
  have "\<not> alive (ref k) s" by fact
  hence "s@@k = init (ltype k)" by simp
  moreover have "s\<turnstile> l reachable_from (s@@k)" by fact
  ultimately have False by simp
  thus ?case ..
qed

lemma loc_new_reach:
  assumes l: "ref l = new s t"
  assumes l_x: "s\<turnstile> l reachable_from x"
  shows "x = new s t"
using l_x l
proof induct
  case (Immediate l)
  show "ref l = new s t" by fact
next
  case (Indirect l k)
  hence "s@@k = new s t" by iprover
  moreover
  have "\<not> alive (new s t) s"
    by simp
  moreover
  have "alive (s@@k) s"
    by simp
  ultimately have False by simp
  thus ?case ..
qed

text \<open>Lemma 3.2 (viii)\<close>
lemma alive_reach_alive:
  assumes alive_x: "alive x s"
  assumes reach_l: "s \<turnstile> l reachable_from x"
  shows "alive (ref l) s"
using reach_l alive_x
proof (induct)
  case (Immediate l)
  show ?case by fact
next
  case (Indirect l k)
  have hyp: "alive (s@@k) s \<Longrightarrow> alive (ref l) s" by fact
  moreover have "alive (s@@k) s" by simp
  ultimately
  show "alive (ref l) s"
    by iprover
qed

text \<open>Lemma 3.2 (ix)\<close>
lemma reach9:
  assumes reach_impl_access_eq: "\<forall>l. s1\<turnstile>l reachable_from x \<longrightarrow> (s1@@l = s2@@l)"
  shows "s1\<turnstile> l reachable_from x = s2\<turnstile> l reachable_from x"
proof
  assume "s1\<turnstile> l reachable_from x"
  from this reach_impl_access_eq
  show "s2\<turnstile> l reachable_from x"
  proof (induct)
    case (Immediate l)
    show "s2\<turnstile> l reachable_from ref l"
      by (rule reach.intros) (rule Immediate.hyps)
  next
    case (Indirect l k)
    have hyp: "\<forall>l. s1\<turnstile> l reachable_from (s1@@k) \<longrightarrow> s1@@l = s2@@l
               \<Longrightarrow> s2\<turnstile> l reachable_from (s1@@k)" by fact
    have k_not_Null: "ref k \<noteq> nullV" by fact
    have reach_impl_access_eq:
      "\<forall>l. s1\<turnstile> l reachable_from ref k \<longrightarrow> s1@@l = s2@@l" by fact
    have "s1\<turnstile> l reachable_from (s1@@k)" by fact
    with k_not_Null
    have "s1@@k = s2@@k"
      by (iprover intro: reach_impl_access_eq [rule_format] reach.intros)
    moreover from reach_impl_access_eq k_not_Null
    have "\<forall>l. s1\<turnstile> l reachable_from (s1@@k) \<longrightarrow> s1@@l = s2@@l"
      by (iprover intro: reach.intros)
    then have "s2\<turnstile> l reachable_from (s1@@k)"
      by (rule hyp)
    ultimately have "s2\<turnstile> l reachable_from (s2@@k)"
      by simp
    thus "s2\<turnstile> l reachable_from ref k"
      by (rule reach.intros) (rule Indirect.hyps)
  qed
next
  assume "s2\<turnstile> l reachable_from x"
  from this reach_impl_access_eq
  show "s1\<turnstile> l reachable_from x"
  proof (induct)
    case (Immediate l)
    show "s1\<turnstile> l reachable_from ref l"
      by (rule reach.intros) (rule Immediate.hyps)
  next
    case (Indirect l k)
    have hyp: "\<forall>l. s1\<turnstile> l reachable_from (s2@@k) \<longrightarrow> s1@@l = s2@@l
               \<Longrightarrow> s1\<turnstile> l reachable_from (s2@@k)" by fact
    have k_not_Null: "ref k \<noteq> nullV" by fact
    have reach_impl_access_eq:
      "\<forall>l. s1\<turnstile> l reachable_from ref k \<longrightarrow> s1@@l = s2@@l" by fact
    have "s1\<turnstile> k reachable_from ref k"
      by (rule reach.intros) (rule Indirect.hyps)
    with reach_impl_access_eq
    have eq_k: "s1@@k = s2@@k"
      by simp
    from reach_impl_access_eq k_not_Null
    have "\<forall>l. s1\<turnstile> l reachable_from (s1@@k) \<longrightarrow> s1@@l = s2@@l"
      by (iprover intro: reach.intros)
    then
    have "\<forall>l. s1\<turnstile> l reachable_from (s2@@k) \<longrightarrow> s1@@l = s2@@l"
      by (simp add: eq_k)
    with eq_k hyp have "s1\<turnstile> l reachable_from (s1@@k)"
      by simp
    thus "s1\<turnstile> l reachable_from ref k"
      by (rule reach.intros) (rule Indirect.hyps)
   qed
qed

subsection \<open>Reachability of a Reference from a Reference\<close>

text \<open>The predicate \<open>rreach\<close> tests whether a value is reachable from
another value. This is an extension of the predicate \<open>oreach\<close> as described
in \<^cite>\<open>\<open>p. 54\<close> in "Poetzsch-Heffter97specification"\<close> because now arrays are handled as well.
\<close>

definition rreach:: "Store \<Rightarrow> Value \<Rightarrow> Value \<Rightarrow> bool"
  ("_\<turnstile>Ref _ reachable'_from _" [91,91,91]90) where
"s\<turnstile>Ref y reachable_from x = (\<exists> l. s\<turnstile> l reachable_from x \<and> y = ref l)"

subsection \<open>Disjointness of Reachable Locations\<close>

text \<open>The predicate \<open>disj\<close> tests whether two values are disjoint
in a given store. Its properties as given in
\<^cite>\<open>\<open>Lemma 3.3, p. 54\<close> in "Poetzsch-Heffter97specification"\<close> are then proven.
\<close>

definition disj:: "Value \<Rightarrow> Value \<Rightarrow> Store \<Rightarrow> bool" where
"disj x y s = (\<forall> l. \<not> s\<turnstile> l reachable_from x \<or> \<not> s\<turnstile> l reachable_from y)"

lemma disjI1: "\<lbrakk>\<And> l. s\<turnstile> l reachable_from x \<Longrightarrow> \<not> s\<turnstile> l reachable_from y\<rbrakk>
 \<Longrightarrow> disj x y s"
  by (simp add: disj_def)

lemma disjI2: "\<lbrakk>\<And> l. s\<turnstile> l reachable_from y \<Longrightarrow> \<not> s\<turnstile> l reachable_from x\<rbrakk>
 \<Longrightarrow> disj x y s"
  by (auto simp add: disj_def)

lemma disj_cases [consumes 1]:
  assumes "disj x y s"
  assumes "\<And> l.  \<not> s\<turnstile> l reachable_from x \<Longrightarrow> P"
  assumes "\<And> l.  \<not> s\<turnstile> l reachable_from y \<Longrightarrow> P"
  shows "P"
  using assms by (auto simp add: disj_def)

text \<open>Lemma 3.3 (i) in \<^cite>\<open>"Poetzsch-Heffter97specification"\<close>\<close>
lemma disj1: "\<lbrakk>disj x y s; \<not> s\<turnstile> l reachable_from x; \<not> s\<turnstile> l reachable_from y\<rbrakk>
              \<Longrightarrow> disj x y (s\<langle>l:=z\<rangle>)"
  by (auto simp add: disj_def)

text \<open>Lemma 3.3 (ii)\<close>
lemma disj2:
  assumes disj_x_y: "disj x y s"
  assumes disj_x_z: "disj x z s"
  assumes unreach_l_x: "\<not> s\<turnstile> l reachable_from x"
  shows "disj x y (s\<langle>l:=z\<rangle>)"
proof (rule disjI1)
  fix k
  assume reach_k_x: "s\<langle>l := z\<rangle>\<turnstile> k reachable_from x"
  show "\<not> s\<langle>l := z\<rangle>\<turnstile> k reachable_from y"
  proof -
    from unreach_l_x reach_k_x
    have reach_s_k_x: "s\<turnstile> k reachable_from x"
      by simp
    with disj_x_z
    have "\<not> s\<turnstile> k reachable_from z"
      by (simp add: disj_def)
    moreover from reach_s_k_x disj_x_y
    have "\<not> s\<turnstile> k reachable_from y"
      by (simp add: disj_def)
    ultimately show ?thesis
      by (rule reach3)
  qed
qed

text \<open>Lemma 3.3 (iii)\<close>
lemma disj3: assumes alive_x_s: "alive x s"
  shows "disj x (new s t) (s\<langle>t\<rangle>)"
proof (rule disjI1,simp only: reach_alloc)
  fix l
  assume reach_l_x: "s\<turnstile> l reachable_from x"
  show "\<not> s\<turnstile> l reachable_from new s t"
  proof
    assume reach_l_new: "s\<turnstile> l reachable_from new s t"
    have unalive_new: "\<not> alive (new s t) s" by simp
    from this reach_l_new
    have  "new s t = ref l"
      by (rule ref_reach_unalive)
    moreover from alive_x_s reach_l_x
    have "alive (ref l) s"
      by (rule alive_reach_alive)
    ultimately show False
      using unalive_new
      by simp
  qed
qed

text \<open>Lemma 3.3 (iv)\<close>
lemma disj4: "\<lbrakk>disj (objV C a) y s; CClassT C \<le> dtype f \<rbrakk>
              \<Longrightarrow> disj (s@@(objV C a)..f) y s"
  by (auto simp add: disj_def)

lemma disj4': "\<lbrakk>disj (arrV T a) y s \<rbrakk>
              \<Longrightarrow> disj (s@@(arrV T a).[i]) y s"
  by (auto simp add: disj_def)

subsection \<open>X-Equivalence\<close>

text \<open>We call two stores $s_1$ and $s_2$ equivalent wrt. a given value $X$
(which is called X-equivalence)
 iff $X$ and all values
reachable from $X$ in $s_1$ or $s_2$ have the same state \<^cite>\<open>\<open>p. 55\<close> in "Poetzsch-Heffter97specification"\<close>.
This is tested by  the predicate
\<open>xeq\<close>. Lemma 3.4 of  \<^cite>\<open>"Poetzsch-Heffter97specification"\<close> is then proven for \<open>xeq\<close>.
\<close>

definition xeq:: "Value \<Rightarrow> Store \<Rightarrow> Store \<Rightarrow> bool" where
"xeq x s t = (alive x s = alive x t \<and>
             (\<forall> l. s\<turnstile> l reachable_from x \<longrightarrow> s@@l = t@@l))"

abbreviation xeq_syntax :: "Store \<Rightarrow> Value \<Rightarrow> Store \<Rightarrow> bool"
  ("_/ (\<equiv>[_])/ _" [900,0,900] 900)
where "s \<equiv>[x] t == xeq x s t"

lemma xeqI: "\<lbrakk>alive x s = alive x t;
             \<And> l. s\<turnstile> l reachable_from x \<Longrightarrow> s@@l = t@@l
             \<rbrakk> \<Longrightarrow> s \<equiv>[x] t"
  by (auto simp add: xeq_def)

text \<open>Lemma 3.4 (i) in  \<^cite>\<open>"Poetzsch-Heffter97specification"\<close>.\<close>
lemma xeq1_refl: "s \<equiv>[x] s"
  by (simp add: xeq_def)

text \<open>Lemma 3.4 (i)\<close>
lemma xeq1_sym':
  assumes s_t: "s \<equiv>[x] t"
  shows "t \<equiv>[x] s"
proof -
  from s_t have "alive x s = alive x t" by (simp add: xeq_def)
  moreover
  from s_t have "\<forall> l. s\<turnstile> l reachable_from x \<longrightarrow> s@@l = t@@l"
    by (simp add: xeq_def)
  with reach9 [OF this]
  have "\<forall> l. t\<turnstile> l reachable_from x \<longrightarrow> t@@l = s@@l"
    by simp
  ultimately show ?thesis
    by (simp add: xeq_def)
qed

lemma xeq1_sym: "s \<equiv>[x] t = t \<equiv>[x] s"
  by (auto intro: xeq1_sym')

text \<open>Lemma 3.4 (i)\<close>
lemma xeq1_trans [trans]:
  assumes s_t: "s \<equiv>[x] t"
  assumes t_r: "t \<equiv>[x] r"
  shows "s \<equiv>[x] r"
proof -
  from s_t t_r
  have "alive x s = alive x r"
    by (simp add: xeq_def)
  moreover
  have "\<forall> l. s\<turnstile> l reachable_from x \<longrightarrow> s@@l = r@@l"
  proof (intro allI impI)
    fix l
    assume reach_l: "s\<turnstile> l reachable_from x"
    show "s@@l = r@@l"
    proof -
      from reach_l s_t have "s@@l=t@@l"
        by (simp add: xeq_def)
      also have "t@@l = r@@l"
      proof -
        from s_t have "\<forall> l. s\<turnstile> l reachable_from x \<longrightarrow> s@@l = t@@l"
          by (simp add: xeq_def)
        from reach9 [OF this] reach_l have "t\<turnstile> l reachable_from x"
          by simp
        with t_r show ?thesis
          by (simp add: xeq_def)
      qed
      finally show ?thesis .
    qed
  qed
  ultimately show ?thesis
    by (simp add: xeq_def)
qed

text \<open>Lemma 3.4 (ii)\<close>
lemma xeq2:
  assumes xeq: "\<forall> x. s \<equiv>[x] t"
  assumes static_eq: "\<forall> f. s@@(staticLoc f) = t@@(staticLoc f)"
  shows "s = t"
proof (rule Store_eqI)
  from xeq
  show "\<forall>x. alive x s = alive x t"
    by (simp add: xeq_def)
next
  show "\<forall>l. s@@l = t@@l"
  proof
    fix l
    show "s@@l = t@@l"
    proof (cases l)
      case (objLoc cf a)
      have "l = objLoc cf a" by fact
      hence "s\<turnstile> l reachable_from (objV (cls cf) a)"
        by simp
      with xeq show ?thesis
        by (simp add: xeq_def)
    next
      case (staticLoc f)
      have "l = staticLoc f" by fact
      with static_eq show ?thesis
        by (simp add: xeq_def)
    next
      case (arrLenLoc T a)
      have "l = arrLenLoc T a" by fact
      hence "s\<turnstile> l reachable_from (arrV T a)"
        by simp
      with xeq show ?thesis
        by (simp add: xeq_def)
    next
      case (arrLoc T a i)
      have "l = arrLoc T a i" by fact
      hence "s\<turnstile> l reachable_from (arrV T a)"
        by simp
      with xeq show ?thesis
        by (simp add: xeq_def)
    qed
  qed
qed

text \<open>Lemma 3.4 (iii)\<close>
lemma xeq3:
  assumes unreach_l: "\<not> s\<turnstile> l reachable_from x"
  shows "s \<equiv>[x] s\<langle>l:=y\<rangle>"
proof (rule xeqI)
  show "alive x s = alive x (s\<langle>l := y\<rangle>)"
    by simp
next
  fix k
  assume reach_k: "s\<turnstile> k reachable_from x"
  with unreach_l have "l\<noteq>k" by auto
  then show "s@@k = s\<langle>l := y\<rangle>@@k"
    by simp
qed

text \<open>Lemma 3.4 (iv)\<close>

text \<open>Lemma 3.4 (v)\<close>
lemma xeq5: "s \<equiv>[x] t \<Longrightarrow> s\<turnstile> l reachable_from x = t\<turnstile> l reachable_from x"
  by (rule reach9) (simp add:  xeq_def)

subsection \<open>T-Equivalence\<close>

text \<open>T-equivalence is the extension of X-equivalence from values to types. Two stores are
T-equivalent iff they are X-equivalent for all values of type T. This is formalized by the
predicate \<open>teq\<close> \<^cite>\<open>\<open>p. 55\<close> in "Poetzsch-Heffter97specification"\<close>.\<close>

definition teq:: "Javatype \<Rightarrow> Store \<Rightarrow> Store \<Rightarrow> bool" where
"teq t s1 s2 = (\<forall> x. typeof x \<le> t \<longrightarrow> s1 \<equiv>[x] s2)"

subsection \<open>Less Alive\<close>

text \<open>To specify that methods have no side-effects, the following binary relation on stores
plays a prominent role. It expresses that the two stores differ only in values that are alive
in the store passed as first argument. This is formalized by the predicate \<open>lessalive\<close>
\<^cite>\<open>\<open>p. 55\<close> in "Poetzsch-Heffter97specification"\<close>.
The stores have to be X-equivalent for the references of the
first store that are alive, and the values of the static fields have to be the same in both stores.
\<close>

definition lessalive:: "Store \<Rightarrow> Store \<Rightarrow> bool" ("_/ \<lless> _" [70,71] 70)
  where "lessalive s t = ((\<forall> x. alive x s \<longrightarrow> s \<equiv>[x] t) \<and> (\<forall> f. s@@staticLoc f = t@@staticLoc f))"

text \<open>We define an introduction rule for the new operator.\<close>

lemma lessaliveI:
  "\<lbrakk>\<And> x. alive x s \<Longrightarrow>  s \<equiv>[x] t; \<And> f. s@@staticLoc f = t@@staticLoc f\<rbrakk>
   \<Longrightarrow> s \<lless> t"
by (simp add: lessalive_def)

text \<open>It can be shown that \<open>lessalive\<close> is reflexive, transitive and antisymmetric.\<close>

lemma lessalive_refl: "s \<lless> s"
  by (simp add: lessalive_def xeq1_refl)

lemma lessalive_trans [trans]:
  assumes s_t: "s \<lless> t"
  assumes t_w: "t \<lless> w"
  shows "s \<lless> w"
proof (rule lessaliveI)
  fix x
  assume alive_x_s: "alive x s"
  with s_t have "s \<equiv>[x] t"
    by (simp add: lessalive_def)
  also
  have "t \<equiv>[x] w"
  proof -
    from alive_x_s s_t have "alive x t" by (simp add: lessalive_def xeq_def)
    with t_w show ?thesis
      by (simp add: lessalive_def)
  qed
  finally show "s \<equiv>[x] w".
next
  fix f
  from s_t t_w show "s@@staticLoc f = w@@staticLoc f"
    by (simp add: lessalive_def)
qed

lemma lessalive_antisym:
  assumes s_t: "s \<lless> t"
  assumes t_s: "t \<lless> s"
  shows "s = t"
proof (rule xeq2)
  show "\<forall>x. s \<equiv>[x] t"
  proof
    fix x show "s \<equiv>[x] t"
    proof (cases "alive x s")
      case True
      with s_t show ?thesis by (simp add: lessalive_def)
    next
      case False note unalive_x_s = this
      show ?thesis
      proof (cases "alive x t")
        case True
        with t_s show ?thesis
          by (subst xeq1_sym) (simp add: lessalive_def)
      next
        case False
        show ?thesis
        proof (rule xeqI)
          from False unalive_x_s show "alive x s = alive x t" by simp
        next
          fix l assume reach_s_x: "s\<turnstile> l reachable_from x"
          with unalive_x_s have x: "x = ref l"
            by (rule ref_reach_unalive)
          with unalive_x_s have "s@@l = init (ltype l)"
            by simp
          also from reach_s_x x have "t\<turnstile> l reachable_from x"
            by (auto intro: reach.Immediate unreachable_Null)
          with False x have "t@@l = init (ltype l)"
            by simp
          finally show "s@@l = t@@l"
            by simp
        qed
      qed
    qed
  qed
next
  from s_t show "\<forall>f. s@@staticLoc f = t@@staticLoc f"
    by (simp add: lessalive_def)
qed

text \<open>This gives us a partial ordering on the store. Thus, the type @{typ "Store"}
can be added to the appropriate type class @{term "ord"} which lets us define the $<$ and
$\leq$ symbols, and to the type class  @{term "order"} which axiomatizes partial orderings.
\<close>

instantiation Store :: order
begin

definition
  le_Store_def: "s \<le> t \<longleftrightarrow> s \<lless> t"

definition
  less_Store_def: "(s::Store) < t \<longleftrightarrow> s \<le> t \<and> \<not> t \<le> s"

text \<open>We prove Lemma 3.5 of \<^cite>\<open>\<open>p. 56\<close> in "Poetzsch-Heffter97specification"\<close> for this relation.
\<close>

text \<open>Lemma 3.5 (i)\<close>

instance  proof
  fix s t w:: "Store"
  {
    show "s \<le> s"
      by (simp add: le_Store_def lessalive_refl)
  next
    assume "s \<le> t" "t \<le> w"
    then show "s \<le> w"
      by (unfold le_Store_def) (rule lessalive_trans)
  next
    assume "s \<le> t" "t \<le> s"
    then show "s = t"
      by (unfold le_Store_def) (rule lessalive_antisym)
  next
    show "(s < t) = (s \<le> t \<and> \<not> t \<le> s)"
      by (simp add: less_Store_def)
  }
qed

end

text \<open>Lemma 3.5 (ii)\<close>
lemma lessalive2: "\<lbrakk>s \<lless> t; alive x s\<rbrakk> \<Longrightarrow> alive x t"
  by (simp add: lessalive_def xeq_def)

text \<open>Lemma 3.5 (iii)\<close>
lemma lessalive3:
  assumes s_t: "s \<lless> t"
  assumes alive: "alive x s \<or> \<not> alive x t"
  shows "s \<equiv>[x] t"
proof (cases "alive x s")
  case True
  with s_t show ?thesis
    by (simp add: lessalive_def)
next
  case False
  note unalive_x_s = this
  with alive have unalive_x_t: "\<not> alive x t"
    by simp
  show ?thesis
  proof (rule xeqI)
    from False alive show "alive x s = alive x t"
      by simp
  next
    fix l assume reach_s_x: "s\<turnstile> l reachable_from x"
    with unalive_x_s have x: "x = ref l"
      by (rule ref_reach_unalive)
    with unalive_x_s have "s@@l = init (ltype l)"
      by simp
    also from reach_s_x x have "t\<turnstile> l reachable_from x"
      by (auto intro: reach.Immediate unreachable_Null)
    with unalive_x_t x have "t@@l = init (ltype l)"
      by simp
    finally show "s@@l = t@@l"
      by simp
  qed
qed

text \<open>Lemma 3.5 (iv)\<close>
lemma lessalive_update [simp,intro]:
  assumes s_t: "s \<lless> t"
  assumes unalive_l: "\<not> alive (ref l) t"
  shows "s \<lless> t\<langle>l:=x\<rangle>"
proof -
  from unalive_l have "t\<langle>l:=x\<rangle> = t"
    by simp
  with s_t show ?thesis by simp
qed

lemma Xequ4':
  assumes alive: "alive x s"
  shows "s \<equiv>[x] s\<langle>t\<rangle>"
proof -
  from alive have "x \<noteq> new s t"
    by auto
  thus ?thesis
    by (rule xeq4)
qed

text \<open>Lemma 3.5 (v)\<close>
lemma lessalive_alloc [simp,intro]: "s \<lless> s\<langle>t\<rangle>"
  by (simp add: lessalive_def Xequ4')

subsection \<open>Reachability of Types from Types\<close>

text \<open>The predicate \<open>treach\<close> denotes the fact that the first type reaches
the second type by stepping finitely many times from a type to the range type of one
of its fields. This formalization diverges from \<^cite>\<open>\<open>p. 106\<close> in "Poetzsch-Heffter97specification"\<close>
in that it does not include the number of steps that are allowed to reach the second type.
Reachability of types is a static approximation of reachability in
the store. If I cannot reach the type of a location from the type of a
reference, I cannot reach the location from the reference. See lemma
\<open>not_treach_ref_impl_not_reach\<close> below.
\<close>

inductive
  treach :: "Javatype \<Rightarrow> Javatype \<Rightarrow> bool"
where
  Subtype:       "U \<le> T \<Longrightarrow> treach T U"
| Attribute:     "\<lbrakk>treach T S; S \<le> dtype f; U \<le> rtype f\<rbrakk>  \<Longrightarrow> treach T U"
| ArrLength:     "treach (ArrT AT) IntgT"
| ArrElem:       "treach (ArrT AT) (at2jt AT)"
| Trans [trans]: "\<lbrakk>treach T U; treach U V\<rbrakk> \<Longrightarrow> treach T V"

lemma treach_ref_l [simp,intro]:
  assumes not_Null: "ref l \<noteq> nullV"
  shows "treach (typeof (ref l)) (ltype l)"
proof (cases l)
  case (objLoc cf a)
  have "l=objLoc cf a" by fact
  moreover
  have "treach (CClassT (cls cf)) (rtype (att cf))"
    by (rule treach.Attribute [where ?f="att cf" and ?S="CClassT (cls cf)"])
       (auto intro: treach.Subtype)
  ultimately show ?thesis
    by simp
next
  case (staticLoc f)
  have "l=staticLoc f" by fact
  hence "ref l = nullV" by simp
  with not_Null show ?thesis
    by simp
next
  case (arrLenLoc T a)
  have "l=arrLenLoc T a" by fact
  then show ?thesis
    by (auto intro: treach.ArrLength)
next
  case (arrLoc T a i)
  have "l=arrLoc T a i" by fact
  then show ?thesis
    by (auto intro: treach.ArrElem)
qed

lemma treach_ref_l' [simp,intro]:
  assumes not_Null: "ref l \<noteq> nullV"
  shows "treach (typeof (ref l)) (typeof (s@@l))"
proof -
  from not_Null have "treach (typeof (ref l)) (ltype l)" by (rule treach_ref_l)
  also have "typeof (s@@l) \<le> ltype l"
    by simp
  hence "treach (ltype l) (typeof (s@@l))"
    by (rule treach.intros)
  finally show ?thesis .
qed

lemma reach_impl_treach:
  assumes reach_l: "s \<turnstile> l reachable_from x"
  shows "treach (typeof x) (ltype l)"
using reach_l
proof (induct)
  case (Immediate l)
  have "ref l \<noteq> nullV" by fact
  then show "treach (typeof (ref l)) (ltype l)"
    by (rule treach_ref_l)
next
  case (Indirect l k)
  have "treach (typeof (s@@k)) (ltype l)" by fact
  moreover
  have "ref k \<noteq> nullV" by fact
  hence "treach (typeof (ref k)) (typeof (s@@k))"
    by simp
  ultimately show "treach (typeof (ref k)) (ltype l)"
    by (iprover intro: treach.Trans)
qed

lemma not_treach_ref_impl_not_reach:
  assumes not_treach: "\<not> treach (typeof x) (typeof (ref l))"
  shows "\<not> s \<turnstile> l reachable_from x"
proof
  assume reach_l: "s\<turnstile> l reachable_from x"
  from this not_treach
  show False
  proof (induct)
    case (Immediate l)
    have "\<not> treach (typeof (ref l)) (typeof (ref l))" by fact
    thus False by (iprover intro: treach.intros order_refl)
  next
    case (Indirect l k)
    have hyp: "\<not> treach (typeof (s@@k)) (typeof (ref l)) \<Longrightarrow> False" by fact
    have not_Null: "ref k \<noteq> nullV" by fact
    have not_k_l:"\<not> treach (typeof (ref k)) (typeof (ref l))" by fact
    show False
    proof (cases "treach (typeof (s@@k)) (typeof (ref l))")
      case False thus False by (rule hyp)
    next
      case True
      from not_Null have "treach (typeof (ref k)) (typeof (s@@k))"
        by (rule treach_ref_l')
      also note True
      finally have "treach (typeof (ref k)) (typeof (ref l))" .
      with not_k_l show False ..
    qed
  qed
qed

text \<open>Lemma 4.6 in \<^cite>\<open>\<open>p. 107\<close> in "Poetzsch-Heffter97specification"\<close>.\<close>
lemma treach1:
  assumes x_t: "typeof x \<le> T"
  assumes not_treach: "\<not> treach T (typeof (ref l))"
  shows "\<not> s \<turnstile> l reachable_from x"
proof -
  have "\<not> treach (typeof x) (typeof (ref l))"
  proof
    from x_t have "treach T (typeof x)" by (rule treach.intros)
    also assume "treach (typeof x) (typeof (ref l))"
    finally have "treach T (typeof (ref l))" .
    with not_treach show False ..
  qed
  thus ?thesis
    by (rule not_treach_ref_impl_not_reach)
qed

end


theory nmap_var
imports "./Optics/Lenses"   "HOL-Library.Adhoc_Overloading"
begin

definition in_var :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> ('a \<Longrightarrow> '\<alpha> \<times> '\<beta>)" where "in_var x = x ;\<^sub>L fst\<^sub>L"

definition out_var :: "('a \<Longrightarrow> '\<beta>) \<Rightarrow> ('a \<Longrightarrow> '\<alpha> \<times> '\<beta>)" where "out_var x = x ;\<^sub>L snd\<^sub>L"

definition univ_alpha :: "('\<alpha> \<Longrightarrow> '\<alpha>)" ("\<Sigma>") where "univ_alpha \<equiv> 1\<^sub>L"

consts svar :: "'v \<Rightarrow> 'e"
definition pr_var :: "('a \<Longrightarrow> '\<beta>) \<Rightarrow> ('a \<Longrightarrow> '\<beta>)" where [lens_defs]: "pr_var x = x"
adhoc_overloading
  svar pr_var

consts
  ivar :: "'v \<Rightarrow> 'e"
  ovar :: "'v \<Rightarrow> 'e"

(*** some proofs about lemmas have put in the last of this theory  ***)

nonterminal svid and svids and svar and svars and salpha

syntax \<comment> \<open> Identifiers \<close>
  "_svid"        :: "id \<Rightarrow> svid" ("_" [999] 999)
  "_svid_unit"   :: "svid \<Rightarrow> svids" ("_")
  "_svid_list"   :: "svid \<Rightarrow> svids \<Rightarrow> svids" ("_,/ _")
  "_svid_alpha"  :: "svid" ("\<^bold>v")
  "_svid_dot"    :: "svid \<Rightarrow> svid \<Rightarrow> svid" ("_:_" [998,999] 998)
syntax \<comment> \<open> Decorations \<close>
  "_spvar"       :: "svid \<Rightarrow> svar" ("&_" [990] 990)
  "_sinvar"      :: "svid \<Rightarrow> svar" ("$_" [990] 990)
  "_soutvar"     :: "svid \<Rightarrow> svar" ("$_\<acute>" [990] 990)
 \<comment> \<open> Variable sets \<close>
  "_salphaid"    :: "svid \<Rightarrow> salpha" ("_" [990] 990)
  "_salphavar"   :: "svar \<Rightarrow> salpha" ("_" [990] 990)
  "_salphaparen" :: "salpha \<Rightarrow> salpha" ("'(_')")
  "_salphacomp"  :: "salpha \<Rightarrow> salpha \<Rightarrow> salpha" (infixr ";" 75)
  "_salphaprod"  :: "salpha \<Rightarrow> salpha \<Rightarrow> salpha" (infixr "\<times>" 85)
  "_salpha_all"  :: "salpha" ("\<Sigma>")
  "_salpha_none" :: "salpha" ("\<emptyset>")
  "_svar_nil"    :: "svar \<Rightarrow> svars" ("_")
  "_svar_cons"   :: "svar \<Rightarrow> svars \<Rightarrow> svars" ("_,/ _")
  "_salphaset"   :: "svars \<Rightarrow> salpha" ("{_}")
  "_salphamk"    :: "logic \<Rightarrow> salpha"

translations
\<comment> \<open> Identifiers \<close>
  "_svid x" \<rightharpoonup> "x"
  "_svid_alpha" \<rightleftharpoons> "\<Sigma>"
  "_svid_dot x y" \<rightharpoonup> "y ;\<^sub>L x"
\<comment> \<open> Decorations \<close>
  "_spvar \<Sigma>"  \<leftharpoondown>  "CONST svar CONST id_lens"
  "_sinvar \<Sigma>"  \<leftharpoondown> "CONST ivar 1\<^sub>L"
  "_soutvar \<Sigma>" \<leftharpoondown> "CONST ovar 1\<^sub>L"
  "_spvar (_svid_dot x y)" \<leftharpoondown> "CONST svar (CONST lens_comp y x)"
  "_sinvar (_svid_dot x y)" \<leftharpoondown> "CONST ivar (CONST lens_comp y x)"
  "_soutvar (_svid_dot x y)" \<leftharpoondown> "CONST ovar (CONST lens_comp y x)"
  "_svid_dot (_svid_dot x y) z" \<leftharpoondown> "_svid_dot (CONST lens_comp y x) z"

  "_spvar x" \<rightleftharpoons> "CONST svar x"
  "_sinvar x" \<rightleftharpoons> "CONST ivar x"
  "_soutvar x" \<rightleftharpoons> "CONST ovar x"
\<comment> \<open> Alphabets \<close>
  "_salphaparen a" \<rightharpoonup> "a"
  "_salphaid x" \<rightharpoonup> "x"
  "_salphacomp x y" \<rightharpoonup> "x +\<^sub>L y"
  "_salphaprod a b" \<rightleftharpoons> "a \<times>\<^sub>L b"
  "_salphavar x" \<rightharpoonup> "x"
  "_svar_nil x" \<rightharpoonup> "x"
  "_svar_cons x xs" \<rightharpoonup> "x +\<^sub>L xs"
  "_salphaset A" \<rightharpoonup> "A"
  "(_svar_cons x (_salphamk y))" \<leftharpoondown> "_salphamk (x +\<^sub>L y)"
  "x" \<leftharpoondown> "_salphamk x"
  "_salpha_all" \<rightleftharpoons> "1\<^sub>L"
  "_salpha_none" \<rightleftharpoons> "0\<^sub>L"

declare fst_vwb_lens [simp]
declare snd_vwb_lens [simp]
declare comp_vwb_lens [simp]
declare lens_indep_left_ext [simp]
declare lens_indep_right_ext [simp]

text \<open> We can now easily show that our UTP variable construction are various classes of  well-behaved lens .\<close>

lemma in_var_uvar [simp]:
  "vwb_lens x \<Longrightarrow> vwb_lens (in_var x)"
  by (simp add: in_var_def)

lemma out_var_uvar [simp]:
  "vwb_lens x \<Longrightarrow> vwb_lens (out_var x)"
  by (simp add: out_var_def)

lemma pr_var_vwb_lens [simp]:
  "vwb_lens x \<Longrightarrow> vwb_lens (pr_var x)"
  by (simp add: pr_var_def)

lemma pr_var_indeps [simp]:
  "x \<bowtie> y \<Longrightarrow> pr_var x \<bowtie> y"
  "x \<bowtie> y \<Longrightarrow> x \<bowtie> pr_var y"
  by (simp_all add: pr_var_def)

lemma in_var_pr_var [simp]:
  "in_var (pr_var x) = in_var x"
  by (simp add: pr_var_def)

lemma out_var_pr_var [simp]:
  "out_var (pr_var x) = out_var x"
  by (simp add: pr_var_def)

lemma pr_var_idem [simp]:
  "pr_var (pr_var x) = pr_var x"
  by (simp add: pr_var_def)

lemma pr_var_lens_plus [simp]:
  "pr_var (x +\<^sub>L y) = (x +\<^sub>L y)"
  by (simp add: pr_var_def)

lemma pr_var_lens_comp_1 [simp]:
  "pr_var x ;\<^sub>L y = pr_var (x ;\<^sub>L y)"
  by (simp add: pr_var_def)

lemma in_var_weak_lens [simp]:
  "weak_lens x \<Longrightarrow> weak_lens (in_var x)"
  by (simp add: comp_weak_lens in_var_def)

lemma in_var_semi_uvar [simp]:
  "mwb_lens x \<Longrightarrow> mwb_lens (in_var x)"
  by (simp add: comp_mwb_lens in_var_def)

lemma pr_var_weak_lens [simp]:
  "weak_lens x \<Longrightarrow> weak_lens (pr_var x)"
  by (simp add: pr_var_def)

lemma pr_var_mwb_lens [simp]:
  "mwb_lens x \<Longrightarrow> mwb_lens (pr_var x)"
  by (simp add: pr_var_def)

lemma in_var_indep [simp]:
  "x \<bowtie> y \<Longrightarrow> in_var x \<bowtie> in_var y"
  by (simp add: in_var_def out_var_def)

lemma out_var_indep [simp]:
  "x \<bowtie> y \<Longrightarrow> out_var x \<bowtie> out_var y"
  by (simp add: out_var_def)

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Basic Setup\<close>
theory Transport_Functions_Base
  imports
    Monotone_Function_Relator
    Transport_Base
begin

paragraph \<open>Summary\<close>
text \<open>Basic setup for closure proofs. We introduce locales for the syntax,
the dependent relator, the non-dependent relator, the monotone dependent relator,
and the monotone non-dependent relator.\<close>

definition "flip2 f x1 x2 x3 x4 \<equiv> f x2 x1 x4 x3"

lemma flip2_eq: "flip2 f x1 x2 x3 x4 = f x2 x1 x4 x3"
  unfolding flip2_def by simp

lemma flip2_eq_rel_inv [simp]: "flip2 R x y = (R y x)\<inverse>"
  by (intro ext) (simp only: flip2_eq rel_inv_iff_rel)

lemma flip2_flip2_eq_self [simp]: "flip2 (flip2 f) = f"
  by (intro ext) (simp add: flip2_eq)

lemma flip2_eq_flip2_iff_eq [iff]: "flip2 f = flip2 g \<longleftrightarrow> f = g"
  unfolding flip2_def by (intro iffI ext) (auto dest: fun_cong)

paragraph \<open>Dependent Function Relator\<close>

locale transport_Dep_Fun_Rel_syntax =
  t1 : transport L1 R1 l1 r1 +
  dfro1 : hom_Dep_Fun_Rel_orders L1 L2 +
  dfro2 : hom_Dep_Fun_Rel_orders R1 R2
  for L1 :: "'a1 \<Rightarrow> 'a1 \<Rightarrow> bool"
  and R1 :: "'a2 \<Rightarrow> 'a2 \<Rightarrow> bool"
  and l1 :: "'a1 \<Rightarrow> 'a2"
  and r1 :: "'a2 \<Rightarrow> 'a1"
  and L2 :: "'a1 \<Rightarrow> 'a1 \<Rightarrow> 'b1 \<Rightarrow> 'b1 \<Rightarrow> bool"
  and R2 :: "'a2 \<Rightarrow> 'a2 \<Rightarrow> 'b2 \<Rightarrow> 'b2 \<Rightarrow> bool"
  and l2 :: "'a2 \<Rightarrow> 'a1 \<Rightarrow> 'b1 \<Rightarrow> 'b2"
  and r2 :: "'a1 \<Rightarrow> 'a2 \<Rightarrow> 'b2 \<Rightarrow> 'b1"
begin

notation L1 (infix "\<le>\<^bsub>L1\<^esub>" 50)
notation R1 (infix "\<le>\<^bsub>R1\<^esub>" 50)

notation t1.ge_left (infix "\<ge>\<^bsub>L1\<^esub>" 50)
notation t1.ge_right (infix "\<ge>\<^bsub>R1\<^esub>" 50)

notation t1.Galois (infix "\<^bsub>L1\<^esub>\<lessapprox>" 50)
notation t1.ge_Galois (infix "\<greaterapprox>\<^bsub>L1\<^esub>" 50)
notation t1.flip_Galois (infix "\<^bsub>R1\<^esub>\<lessapprox>" 50)
notation t1.flip_ge_Galois (infix "\<greaterapprox>\<^bsub>R1\<^esub>" 50)
notation t1.flip_inv_Galois (infix "\<^bsub>R1\<^esub>\<greaterapprox>" 50)
notation t1.flip_inv_ge_Galois (infix "\<lessapprox>\<^bsub>R1\<^esub>" 50)
notation t1.flip_flip_inv_Galois (infix "\<^bsub>L1\<^esub>\<greaterapprox>" 50)
notation t1.flip_flip_inv_ge_Galois (infix "\<lessapprox>\<^bsub>L1\<^esub>" 50)

notation t1.unit ("\<eta>\<^sub>1")
notation t1.counit ("\<epsilon>\<^sub>1")

notation L2 ("(\<le>\<^bsub>L2 (_) (_)\<^esub>)" 50)
notation R2 ("(\<le>\<^bsub>R2 (_) (_)\<^esub>)" 50)

notation dfro1.right_infix ("(_) \<le>\<^bsub>L2 (_) (_)\<^esub> (_)" [51,51,51,51] 50)
notation dfro2.right_infix ("(_) \<le>\<^bsub>R2 (_) (_)\<^esub> (_)" [51,51,51,51] 50)

notation dfro1.o.ge_right ("(\<ge>\<^bsub>L2 (_) (_)\<^esub>)" 50)
notation dfro2.o.ge_right ("(\<ge>\<^bsub>R2 (_) (_)\<^esub>)" 50)

notation dfro1.ge_right_infix ("(_) \<ge>\<^bsub>L2 (_) (_)\<^esub> (_)" [51,51,51,51] 50)
notation dfro2.ge_right_infix ("(_) \<ge>\<^bsub>R2 (_) (_)\<^esub> (_)" [51,51,51,51] 50)

notation l2 ("l2\<^bsub>(_) (_)\<^esub>")
notation r2 ("r2\<^bsub>(_) (_)\<^esub>")

sublocale t2 : transport "(\<le>\<^bsub>L2 x (r1 x')\<^esub>)" "(\<le>\<^bsub>R2 (l1 x) x'\<^esub>)" "l2\<^bsub>x' x\<^esub>" "r2\<^bsub>x x'\<^esub>" for x x' .

notation t2.Galois ("(\<^bsub>L2 (_) (_)\<^esub>\<lessapprox>)" 50)
notation t2.flip_Galois ("(\<^bsub>R2 (_) (_)\<^esub>\<lessapprox>)" 50)

abbreviation "left2_Galois_infix y x x' y' \<equiv> (\<^bsub>L2 x x'\<^esub>\<lessapprox>) y y'"
notation left2_Galois_infix ("(_) \<^bsub>L2 (_) (_)\<^esub>\<lessapprox> (_)" [51,51,51,51] 50)
abbreviation "right2_Galois_infix y' x x' y \<equiv> (\<^bsub>R2 x x'\<^esub>\<lessapprox>) y' y"
notation right2_Galois_infix ("(_) \<^bsub>R2 (_) (_)\<^esub>\<lessapprox> (_)" [51,51,51,51] 50)

notation t2.ge_Galois ("(\<greaterapprox>\<^bsub>L2 (_) (_)\<^esub>)" 50)
notation t2.flip_ge_Galois ("(\<greaterapprox>\<^bsub>R2 (_) (_)\<^esub>)" 50)

abbreviation (input) "ge_Galois_left2_infix y' x x' y \<equiv> (\<greaterapprox>\<^bsub>L2 x x'\<^esub>) y' y"
notation ge_Galois_left2_infix ("(_) \<greaterapprox>\<^bsub>L2 (_) (_)\<^esub> (_)" [51,51,51,51] 50)
abbreviation (input) "ge_Galois_right2_infix y x x' y' \<equiv> (\<greaterapprox>\<^bsub>R2 x x'\<^esub>) y y'"
notation ge_Galois_right2_infix ("(_) \<greaterapprox>\<^bsub>R2 (_) (_)\<^esub> (_)" [51,51,51,51] 50)

notation t2.flip_inv_Galois ("(\<^bsub>R2 (_) (_)\<^esub>\<greaterapprox>)" 50)
notation t2.flip_flip_inv_Galois ("(\<^bsub>L2 (_) (_)\<^esub>\<greaterapprox>)" 50)

abbreviation "left2_ge_Galois_infix y x x' y' \<equiv> (\<^bsub>L2 x x'\<^esub>\<greaterapprox>) y y'"
notation left2_ge_Galois_infix ("(_) \<^bsub>L2 (_) (_)\<^esub>\<greaterapprox> (_)" [51,51,51,51] 50)
abbreviation "right2_ge_Galois_infix y' x x' y \<equiv> (\<^bsub>R2 x x'\<^esub>\<greaterapprox>) y' y"
notation right2_ge_Galois_infix ("(_) \<^bsub>R2 (_) (_)\<^esub>\<greaterapprox> (_)" [51,51,51,51] 50)

notation t2.flip_inv_ge_Galois ("(\<lessapprox>\<^bsub>R2 (_) (_)\<^esub>)" 50)
notation t2.flip_flip_inv_ge_Galois ("(\<lessapprox>\<^bsub>L2 (_) (_)\<^esub>)" 50)

abbreviation (input) "Galois_left2_infix y' x x' y \<equiv> (\<lessapprox>\<^bsub>L2 x x'\<^esub>) y' y"
notation Galois_left2_infix ("(_) \<lessapprox>\<^bsub>L2 (_) (_)\<^esub> (_)" [51,51,51,51] 50)
abbreviation (input) "Galois_right2_infix y x x' y' \<equiv> (\<lessapprox>\<^bsub>R2 x x'\<^esub>) y y'"
notation Galois_right2_infix ("(_) \<lessapprox>\<^bsub>R2 (_) (_)\<^esub> (_)" [51,51,51,51] 50)

abbreviation "t2_unit x x' \<equiv> t2.unit x' x"
notation t2_unit ("\<eta>\<^bsub>2 (_) (_)\<^esub>")
abbreviation "t2_counit x x' \<equiv> t2.counit x' x"
notation t2_counit ("\<epsilon>\<^bsub>2 (_) (_)\<^esub>")

end

locale transport_Dep_Fun_Rel =
  transport_Dep_Fun_Rel_syntax L1 R1 l1 r1 L2 R2 l2 r2
  for L1 :: "'a1 \<Rightarrow> 'a1 \<Rightarrow> bool"
  and R1 :: "'a2 \<Rightarrow> 'a2 \<Rightarrow> bool"
  and l1 :: "'a1 \<Rightarrow> 'a2"
  and r1 :: "'a2 \<Rightarrow> 'a1"
  and L2 :: "'a1 \<Rightarrow> 'a1 \<Rightarrow> 'b1 \<Rightarrow> 'b1 \<Rightarrow> bool"
  and R2 :: "'a2 \<Rightarrow> 'a2 \<Rightarrow> 'b2 \<Rightarrow> 'b2 \<Rightarrow> bool"
  and l2 :: "'a2 \<Rightarrow> 'a1 \<Rightarrow> 'b1 \<Rightarrow> 'b2"
  and r2 :: "'a1 \<Rightarrow> 'a2 \<Rightarrow> 'b2 \<Rightarrow> 'b1"
begin

definition "L \<equiv> [x1 x2 \<Colon> (\<le>\<^bsub>L1\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>L2 x1 x2\<^esub>)"

lemma left_rel_eq_Dep_Fun_Rel: "L = ([x1 x2 \<Colon> (\<le>\<^bsub>L1\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>L2 x1 x2\<^esub>))"
  unfolding L_def ..

definition "l \<equiv> ([x' : r1] \<rightarrow> l2 x')"

lemma left_eq_dep_fun_map: "l = ([x' : r1] \<rightarrow> l2 x')"
  unfolding l_def ..

lemma left_eq [simp]: "l f x' = l2\<^bsub>x' (r1 x')\<^esub> (f (r1 x'))"
  unfolding left_eq_dep_fun_map by simp

context
begin

interpretation flip : transport_Dep_Fun_Rel R1 L1 r1 l1 R2 L2 r2 l2 .

abbreviation "R \<equiv> flip.L"
abbreviation "r \<equiv> flip.l"

lemma right_rel_eq_Dep_Fun_Rel: "R = ([x1' x2' \<Colon> (\<le>\<^bsub>R1\<^esub>)] \<Rrightarrow> (\<le>\<^bsub>R2 x1' x2'\<^esub>))"
  unfolding flip.L_def ..

lemma right_eq_dep_fun_map: "r = ([x : l1] \<rightarrow> r2 x)"
  unfolding flip.l_def ..

end

lemma right_eq [simp]: "r g x = r2\<^bsub>x (l1 x)\<^esub> (g (l1 x))"
  unfolding right_eq_dep_fun_map by simp

lemmas transport_defs = left_rel_eq_Dep_Fun_Rel left_eq_dep_fun_map
  right_rel_eq_Dep_Fun_Rel right_eq_dep_fun_map

sublocale transport L R l r .

(*FIXME: somehow the notation for the fixed parameters L and R, defined in
Order_Functions_Base.thy, is lost. We hence re-declare it here.*)
notation L (infix "\<le>\<^bsub>L\<^esub>" 50)
notation R (infix "\<le>\<^bsub>R\<^esub>" 50)

lemma left_relI [intro]:
  assumes "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> f x1 \<le>\<^bsub>L2 x1 x2\<^esub> f' x2"
  shows "f \<le>\<^bsub>L\<^esub> f'"
  unfolding left_rel_eq_Dep_Fun_Rel using assms by blast

lemma left_relE [elim]:
  assumes "f \<le>\<^bsub>L\<^esub> f'"
  and "x1 \<le>\<^bsub>L1\<^esub> x2"
  obtains "f x1 \<le>\<^bsub>L2 x1 x2\<^esub> f' x2"
  using assms unfolding left_rel_eq_Dep_Fun_Rel by blast

interpretation flip_inv :
  transport_Dep_Fun_Rel "(\<ge>\<^bsub>R1\<^esub>)" "(\<ge>\<^bsub>L1\<^esub>)" r1 l1 "flip2 R2" "flip2 L2" r2 l2 .

lemma flip_inv_right_eq_ge_left: "flip_inv.R = (\<ge>\<^bsub>L\<^esub>)"
  unfolding left_rel_eq_Dep_Fun_Rel flip_inv.right_rel_eq_Dep_Fun_Rel
  by (simp only: rel_inv_Dep_Fun_Rel_rel_eq flip2_eq_rel_inv[symmetric, of "L2"])

interpretation flip : transport_Dep_Fun_Rel R1 L1 r1 l1 R2 L2 r2 l2 .

lemma flip_inv_left_eq_ge_right: "flip_inv.L \<equiv> (\<ge>\<^bsub>R\<^esub>)"
  unfolding flip.flip_inv_right_eq_ge_left .

subparagraph \<open>Useful Rewritings for Dependent Relation\<close>

lemma left_rel2_unit_eqs_left_rel2I:
  assumes "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> (\<le>\<^bsub>L2 x2 x2\<^esub>) \<le> (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  and "\<And>x. x \<le>\<^bsub>L1\<^esub> x \<Longrightarrow> (\<le>\<^bsub>L2 (\<eta>\<^sub>1 x) x\<^esub>) \<le> (\<le>\<^bsub>L2 x x\<^esub>)"
  and "\<And>x1 x2. x1 \<le>\<^bsub>L1\<^esub> x2 \<Longrightarrow> (\<le>\<^bsub>L2 x1 x1\<^esub>) \<le> (\<le>\<^bsub>L2 x1 x2\<^esub>)"
  and "\<And>x. x \<le>\<^bsub>L1\<^esub> x \<Longrightarrow> (\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>) \<le> (\<le>\<^bsub>L2 x x\<^esub>)"
  and "x \<le>\<^bsub>L1\<^esub> x"
  and "x \<equiv>\<^bsub>L1\<^esub> \<eta>\<^sub>1 x"
  shows "(\<le>\<^bsub>L2 (\<eta>\<^sub>1 x) x\<^esub>) = (\<le>\<^bsub>L2 x x\<^esub>)"
  and "(\<le>\<^bsub>L2 x (\<eta>\<^sub>1 x)\<^esub>) = (\<le>\<^bsub>L2 x x\<^esub>)"
  using assms by (auto intro!: antisym)

lemma left2_eq_if_bi_related_if_monoI:
  assumes mono_L2: "([x1 x2 \<Colon> (\<ge>\<^bsub>L1\<^esub>)] \<Rrightarrow>\<^sub>m [x3 x4 \<Colon> (\<le>\<^bsub>L1\<^esub>) | x1 \<le>\<^bsub>L1\<^esub> x3] \<Rrightarrow> (\<le>)) L2"
  and "x1 \<le>\<^bsub>L1\<^esub> x2"
  and "x1 \<equiv>\<^bsub>L1\<^esub> x3"
  and "x2 \<equiv>\<^bsub>L1\<^esub> x4"
  and trans_L1: "transitive (\<le>\<^bsub>L1\<^esub>)"
  shows "(\<le>\<^bsub>L2 x1 x2\<^esub>) = (\<le>\<^bsub>L2 x3 x4\<^esub>)"
proof (intro antisym)
  from \<open>x1 \<equiv>\<^bsub>L1\<^esub> x3\<close> \<open>x2 \<equiv>\<^bsub>L1\<^esub> x4\<close> have "x3 \<le>\<^bsub>L1\<^esub> x1" "x2 \<le>\<^bsub>L1\<^esub> x4" by auto
  with \<open>x1 \<le>\<^bsub>L1\<^esub> x2\<close> mono_L2 show "(\<le>\<^bsub>L2 x1 x2\<^esub>) \<le> (\<le>\<^bsub>L2 x3 x4\<^esub>)" by blast
  from \<open>x1 \<equiv>\<^bsub>L1\<^esub> x3\<close> \<open>x2 \<equiv>\<^bsub>L1\<^esub> x4\<close> have "x1 \<le>\<^bsub>L1\<^esub> x3" "x4 \<le>\<^bsub>L1\<^esub> x2" by auto
  moreover from \<open>x3 \<le>\<^bsub>L1\<^esub> x1\<close> \<open>x1 \<le>\<^bsub>L1\<^esub> x2\<close> \<open>x2 \<le>\<^bsub>L1\<^esub> x4\<close> have "x3 \<le>\<^bsub>L1\<^esub> x4"
    using trans_L1 by blast
  ultimately show "(\<le>\<^bsub>L2 x3 x4\<^esub>) \<le> (\<le>\<^bsub>L2 x1 x2\<^esub>)" using mono_L2 by blast
qed

end

paragraph \<open>Function Relator\<close>

locale transport_Fun_Rel_syntax =
  tdfrs : transport_Dep_Fun_Rel_syntax L1 R1 l1 r1 "\<lambda>_ _. L2" "\<lambda>_ _. R2"
    "\<lambda>_ _. l2" "\<lambda>_ _. r2"
  for L1 :: "'a1 \<Rightarrow> 'a1 \<Rightarrow> bool"
  and R1 :: "'a2 \<Rightarrow> 'a2 \<Rightarrow> bool"
  and l1 :: "'a1 \<Rightarrow> 'a2"
  and r1 :: "'a2 \<Rightarrow> 'a1"
  and L2 :: "'b1 \<Rightarrow> 'b1 \<Rightarrow> bool"
  and R2 :: "'b2 \<Rightarrow> 'b2 \<Rightarrow> bool"
  and l2 :: "'b1 \<Rightarrow> 'b2"
  and r2 :: "'b2 \<Rightarrow> 'b1"
begin

notation L1 (infix "\<le>\<^bsub>L1\<^esub>" 50)
notation R1 (infix "\<le>\<^bsub>R1\<^esub>" 50)

notation tdfrs.t1.ge_left (infix "\<ge>\<^bsub>L1\<^esub>" 50)
notation tdfrs.t1.ge_right (infix "\<ge>\<^bsub>R1\<^esub>" 50)

notation tdfrs.t1.Galois (infix "\<^bsub>L1\<^esub>\<lessapprox>" 50)
notation tdfrs.t1.ge_Galois (infix "\<greaterapprox>\<^bsub>L1\<^esub>" 50)
notation tdfrs.t1.flip_Galois (infix "\<^bsub>R1\<^esub>\<lessapprox>" 50)
notation tdfrs.t1.flip_ge_Galois (infix "\<greaterapprox>\<^bsub>R1\<^esub>" 50)
notation tdfrs.t1.flip_inv_Galois (infix "\<^bsub>R1\<^esub>\<greaterapprox>" 50)
notation tdfrs.t1.flip_inv_ge_Galois (infix "\<lessapprox>\<^bsub>R1\<^esub>" 50)
notation tdfrs.t1.flip_flip_inv_Galois (infix "\<^bsub>L1\<^esub>\<greaterapprox>" 50)
notation tdfrs.t1.flip_flip_inv_ge_Galois (infix "\<lessapprox>\<^bsub>L1\<^esub>" 50)

notation tdfrs.t1.unit ("\<eta>\<^sub>1")
notation tdfrs.t1.counit ("\<epsilon>\<^sub>1")

notation L2 (infix "\<le>\<^bsub>L2\<^esub>" 50)
notation R2 (infix "\<le>\<^bsub>R2\<^esub>" 50)

notation tdfrs.t2.ge_left (infix "\<ge>\<^bsub>L2\<^esub>" 50)
notation tdfrs.t2.ge_right (infix "\<ge>\<^bsub>R2\<^esub>" 50)

notation tdfrs.t2.Galois (infix "\<^bsub>L2\<^esub>\<lessapprox>" 50)
notation tdfrs.t2.ge_Galois (infix "\<greaterapprox>\<^bsub>L2\<^esub>" 50)
notation tdfrs.t2.flip_Galois (infix "\<^bsub>R2\<^esub>\<lessapprox>" 50)
notation tdfrs.t2.flip_ge_Galois (infix "\<greaterapprox>\<^bsub>R2\<^esub>" 50)
notation tdfrs.t2.flip_inv_Galois (infix "\<^bsub>R2\<^esub>\<greaterapprox>" 50)
notation tdfrs.t2.flip_inv_ge_Galois (infix "\<lessapprox>\<^bsub>R2\<^esub>" 50)
notation tdfrs.t2.flip_flip_inv_Galois (infix "\<^bsub>L2\<^esub>\<greaterapprox>" 50)
notation tdfrs.t2.flip_flip_inv_ge_Galois (infix "\<lessapprox>\<^bsub>L2\<^esub>" 50)

notation tdfrs.t2.unit ("\<eta>\<^sub>2")
notation tdfrs.t2.counit ("\<epsilon>\<^sub>2")

end

locale transport_Fun_Rel =
  transport_Fun_Rel_syntax L1 R1 l1 r1 L2 R2 l2 r2 +
  tdfr : transport_Dep_Fun_Rel L1 R1 l1 r1 "\<lambda>_ _. L2" "\<lambda>_ _. R2"
    "\<lambda>_ _. l2" "\<lambda>_ _. r2"
  for L1 :: "'a1 \<Rightarrow> 'a1 \<Rightarrow> bool"
  and R1 :: "'a2 \<Rightarrow> 'a2 \<Rightarrow> bool"
  and l1 :: "'a1 \<Rightarrow> 'a2"
  and r1 :: "'a2 \<Rightarrow> 'a1"
  and L2 :: "'b1 \<Rightarrow> 'b1 \<Rightarrow> bool"
  and R2 :: "'b2 \<Rightarrow> 'b2 \<Rightarrow> bool"
  and l2 :: "'b1 \<Rightarrow> 'b2"
  and r2 :: "'b2 \<Rightarrow> 'b1"
begin

(*FIXME: we have to repeat the Galois syntax here since tdfr already contains
a Galois instance, blocking a galois sublocale interpretation here*)
notation tdfr.L ("L")
notation tdfr.R ("R")

abbreviation "l \<equiv> tdfr.l"
abbreviation "r \<equiv> tdfr.r"

notation tdfr.L (infix "\<le>\<^bsub>L\<^esub>" 50)
notation tdfr.R (infix "\<le>\<^bsub>R\<^esub>" 50)

notation tdfr.ge_left (infix "\<ge>\<^bsub>L\<^esub>" 50)
notation tdfr.ge_right (infix "\<ge>\<^bsub>R\<^esub>" 50)

notation tdfr.Galois (infix "\<^bsub>L\<^esub>\<lessapprox>" 50)
notation tdfr.ge_Galois (infix "\<greaterapprox>\<^bsub>L\<^esub>" 50)
notation tdfr.flip_Galois (infix "\<^bsub>R\<^esub>\<lessapprox>" 50)
notation tdfr.flip_ge_Galois (infix "\<greaterapprox>\<^bsub>R\<^esub>" 50)
notation tdfr.flip_inv_Galois (infix "\<^bsub>R\<^esub>\<greaterapprox>" 50)
notation tdfr.flip_inv_ge_Galois (infix "\<lessapprox>\<^bsub>R\<^esub>" 50)
notation tdfr.flip_flip_inv_Galois (infix "\<^bsub>L\<^esub>\<greaterapprox>" 50)
notation tdfr.flip_flip_inv_ge_Galois (infix "\<lessapprox>\<^bsub>L\<^esub>" 50)

notation tdfr.unit ("\<eta>")
notation tdfr.counit ("\<epsilon>")

lemma left_rel_eq_Fun_Rel: "(\<le>\<^bsub>L\<^esub>) = ((\<le>\<^bsub>L1\<^esub>) \<Rrightarrow> (\<le>\<^bsub>L2\<^esub>))"
  unfolding tdfr.left_rel_eq_Dep_Fun_Rel by simp

lemma left_eq_fun_map: "l = (r1 \<rightarrow> l2)"
  by (intro ext) simp

interpretation flip : transport_Fun_Rel R1 L1 r1 l1 R2 L2 r2 l2 .

lemma right_rel_eq_Fun_Rel: "(\<le>\<^bsub>R\<^esub>) = ((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow> (\<le>\<^bsub>R2\<^esub>))"
  unfolding flip.left_rel_eq_Fun_Rel ..

lemma right_eq_fun_map: "r = (l1 \<rightarrow> r2)"
  unfolding flip.left_eq_fun_map ..

lemmas transport_defs = left_rel_eq_Fun_Rel right_rel_eq_Fun_Rel
  left_eq_fun_map right_eq_fun_map

end

paragraph \<open>Monotone Dependent Function Relator\<close>

locale transport_Mono_Dep_Fun_Rel =
  transport_Dep_Fun_Rel_syntax L1 R1 l1 r1 L2 R2 l2 r2
  + tdfr : transport_Dep_Fun_Rel L1 R1 l1 r1 L2 R2 l2 r2
  for L1 :: "'a1 \<Rightarrow> 'a1 \<Rightarrow> bool"
  and R1 :: "'a2 \<Rightarrow> 'a2 \<Rightarrow> bool"
  and l1 :: "'a1 \<Rightarrow> 'a2"
  and r1 :: "'a2 \<Rightarrow> 'a1"
  and L2 :: "'a1 \<Rightarrow> 'a1 \<Rightarrow> 'b1 \<Rightarrow> 'b1 \<Rightarrow> bool"
  and R2 :: "'a2 \<Rightarrow> 'a2 \<Rightarrow> 'b2 \<Rightarrow> 'b2 \<Rightarrow> bool"
  and l2 :: "'a2 \<Rightarrow> 'a1 \<Rightarrow> 'b1 \<Rightarrow> 'b2"
  and r2 :: "'a1 \<Rightarrow> 'a2 \<Rightarrow> 'b2 \<Rightarrow> 'b1"
begin

definition "L \<equiv> tdfr.L\<^sup>\<oplus>"

lemma left_rel_eq_tdfr_left_Refl_Rel: "L = tdfr.L\<^sup>\<oplus>"
  unfolding L_def ..

lemma left_rel_eq_Mono_Dep_Fun_Rel: "L = ([x1 x2 \<Colon> (\<le>\<^bsub>L1\<^esub>)] \<Rrightarrow>\<oplus> (\<le>\<^bsub>L2 x1 x2\<^esub>))"
  unfolding left_rel_eq_tdfr_left_Refl_Rel tdfr.left_rel_eq_Dep_Fun_Rel by simp

lemma left_rel_eq_tdfr_left_rel_if_reflexive_on:
  assumes "reflexive_on (in_field tdfr.L) tdfr.L"
  shows "L = tdfr.L"
  unfolding left_rel_eq_tdfr_left_Refl_Rel using assms
  by (rule Refl_Rel_eq_self_if_reflexive_on)

abbreviation "l \<equiv> tdfr.l"

lemma left_eq_tdfr_left: "l = tdfr.l" ..

interpretation flip : transport_Mono_Dep_Fun_Rel R1 L1 r1 l1 R2 L2 r2 l2 .

abbreviation "R \<equiv> flip.L"

lemma right_rel_eq_tdfr_right_Refl_Rel: "R = tdfr.R\<^sup>\<oplus>"
  unfolding flip.left_rel_eq_tdfr_left_Refl_Rel ..

lemma right_rel_eq_Mono_Dep_Fun_Rel: "R = ([y1 y2 \<Colon> (\<le>\<^bsub>R1\<^esub>)] \<Rrightarrow>\<oplus> (\<le>\<^bsub>R2 y1 y2\<^esub>))"
  unfolding flip.left_rel_eq_Mono_Dep_Fun_Rel ..

lemma right_rel_eq_tdfr_right_rel_if_reflexive_on:
  assumes "reflexive_on (in_field tdfr.R) tdfr.R"
  shows "R = tdfr.R"
  using assms by (rule flip.left_rel_eq_tdfr_left_rel_if_reflexive_on)

abbreviation "r \<equiv> tdfr.r"

lemma right_eq_tdfr_right: "r = tdfr.r" ..

lemmas transport_defs = left_rel_eq_tdfr_left_Refl_Rel
  right_rel_eq_tdfr_right_Refl_Rel

sublocale transport L R l r .

(*FIXME: somehow the notation for the fixed parameters L and R, defined in
Order_Functions_Base.thy, is lost. We hence re-declare it here.*)
notation L (infix "\<le>\<^bsub>L\<^esub>" 50)
notation R (infix "\<le>\<^bsub>R\<^esub>" 50)

end

paragraph \<open>Monotone Function Relator\<close>

locale transport_Mono_Fun_Rel =
  transport_Fun_Rel_syntax L1 R1 l1 r1 L2 R2 l2 r2 +
  tfr : transport_Fun_Rel L1 R1 l1 r1 L2 R2 l2 r2 +
  tpdfr : transport_Mono_Dep_Fun_Rel L1 R1 l1 r1 "\<lambda>_ _. L2" "\<lambda>_ _. R2"
    "\<lambda>_ _. l2" "\<lambda>_ _. r2"
  for L1 :: "'a1 \<Rightarrow> 'a1 \<Rightarrow> bool"
  and R1 :: "'a2 \<Rightarrow> 'a2 \<Rightarrow> bool"
  and l1 :: "'a1 \<Rightarrow> 'a2"
  and r1 :: "'a2 \<Rightarrow> 'a1"
  and L2 :: "'b1 \<Rightarrow> 'b1 \<Rightarrow> bool"
  and R2 :: "'b2 \<Rightarrow> 'b2 \<Rightarrow> bool"
  and l2 :: "'b1 \<Rightarrow> 'b2"
  and r2 :: "'b2 \<Rightarrow> 'b1"
begin

(*FIXME: we have to repeat the Galois syntax here since tdfr already contains
a Galois instance, blocking a galois sublocale interpretation here*)
notation tpdfr.L ("L")
notation tpdfr.R ("R")

abbreviation "l \<equiv> tpdfr.l"
abbreviation "r \<equiv> tpdfr.r"

notation tpdfr.L (infix "\<le>\<^bsub>L\<^esub>" 50)
notation tpdfr.R (infix "\<le>\<^bsub>R\<^esub>" 50)

notation tpdfr.ge_left (infix "\<ge>\<^bsub>L\<^esub>" 50)
notation tpdfr.ge_right (infix "\<ge>\<^bsub>R\<^esub>" 50)

notation tpdfr.Galois (infix "\<^bsub>L\<^esub>\<lessapprox>" 50)
notation tpdfr.ge_Galois (infix "\<greaterapprox>\<^bsub>L\<^esub>" 50)
notation tpdfr.flip_Galois (infix "\<^bsub>R\<^esub>\<lessapprox>" 50)
notation tpdfr.flip_ge_Galois (infix "\<greaterapprox>\<^bsub>R\<^esub>" 50)
notation tpdfr.flip_inv_Galois (infix "\<^bsub>R\<^esub>\<greaterapprox>" 50)
notation tpdfr.flip_inv_ge_Galois (infix "\<lessapprox>\<^bsub>R\<^esub>" 50)
notation tpdfr.flip_flip_inv_Galois (infix "\<^bsub>L\<^esub>\<greaterapprox>" 50)
notation tpdfr.flip_flip_inv_ge_Galois (infix "\<lessapprox>\<^bsub>L\<^esub>" 50)

notation tpdfr.unit ("\<eta>")
notation tpdfr.counit ("\<epsilon>")

lemma left_rel_eq_Mono_Fun_Rel: "(\<le>\<^bsub>L\<^esub>) = ((\<le>\<^bsub>L1\<^esub>) \<Rrightarrow>\<oplus> (\<le>\<^bsub>L2\<^esub>))"
  unfolding tpdfr.left_rel_eq_Mono_Dep_Fun_Rel by simp

lemma left_eq_fun_map: "l = (r1 \<rightarrow> l2)"
  unfolding tfr.left_eq_fun_map ..

interpretation flip : transport_Mono_Fun_Rel R1 L1 r1 l1 R2 L2 r2 l2 .

lemma right_rel_eq_Mono_Fun_Rel: "(\<le>\<^bsub>R\<^esub>) = ((\<le>\<^bsub>R1\<^esub>) \<Rrightarrow>\<oplus> (\<le>\<^bsub>R2\<^esub>))"
  unfolding flip.left_rel_eq_Mono_Fun_Rel ..

lemma right_eq_fun_map: "r = (l1 \<rightarrow> r2)"
  unfolding flip.left_eq_fun_map ..

lemmas transport_defs = tpdfr.transport_defs

end

end