(*
 * Copyright 2019, NTU
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 *  Author: Albert Rizaldi, NTU Singapore
 *)

theory Decoder
  imports VHDL_Hoare_Complete
begin

datatype sig = IN | OUT

abbreviation dec_list :: "(sig choices \<times> sig seq_stmt) list" where
  "dec_list \<equiv>
[ (Explicit (Bliteral Neu (to_bl (0b00 :: 2 word))), Bassign_trans OUT (Bliteral Neu (to_bl (0x1:: 4 word))) 1)
, (Explicit (Bliteral Neu (to_bl (0b01 :: 2 word))), Bassign_trans OUT (Bliteral Neu (to_bl (0x2:: 4 word))) 1)
, (Explicit (Bliteral Neu (to_bl (0b10 :: 2 word))), Bassign_trans OUT (Bliteral Neu (to_bl (0x4:: 4 word))) 1)
, (Explicit (Bliteral Neu (to_bl (0b11 :: 2 word))), Bassign_trans OUT (Bliteral Neu (to_bl (0x8:: 4 word))) 1)
]"

definition dec :: "sig conc_stmt" where
  "dec = process {IN} : Bcase (Bsig IN) dec_list"

lemma potential_tyenv:
  assumes "seq_wt \<Gamma> (Bcase (Bsig IN) dec_list)"
  shows   "\<Gamma> IN = Lty Neu 2 \<and> \<Gamma> OUT = Lty Neu 4"
proof (rule seq_wt_cases_bcase[OF assms, rotated 2])
  fix ty exp' ss choices
  assume "bexp_wt \<Gamma> (Bsig IN) ty"
  assume "bexp_wt \<Gamma> exp' ty"
  assume "seq_wt \<Gamma> ss"
  assume "seq_wt \<Gamma> (Bcase (Bsig IN) choices)"
  assume "dec_list = ((Explicit exp', ss) # choices)"
  hence "exp' = Bliteral Neu (to_bl (0b00 :: 2 word))" and "choices = tl dec_list" and
        ss_def: "ss = Bassign_trans OUT (Bliteral Neu (to_bl (0x1 :: 4 word))) 1"
    by auto
  hence 0: "bexp_wt \<Gamma> (Bliteral Neu (to_bl (0b000 :: 2 word))) ty"
    using \<open>bexp_wt \<Gamma> exp' ty\<close> by auto
  have "ty = Lty Neu 2"
    by (rule bexp_wt_cases_lit[OF 0]) auto
  with \<open>bexp_wt \<Gamma> (Bsig IN) ty\<close> have "\<Gamma> IN = Lty Neu 2"
    by (metis bexp_wt_cases_slice(2))
  hence 1: "seq_wt \<Gamma> (Bassign_trans OUT (Bliteral Neu (to_bl (0x1 :: 4 word))) 1)"
    using \<open>seq_wt \<Gamma> ss\<close> unfolding ss_def by auto
  have "\<Gamma> OUT = Lty Neu 4"
    apply (rule seq_wt_cases(4)[OF 1])
    apply (erule bexp_wt_cases_lit)
    by auto
  thus ?thesis
    using \<open>\<Gamma> IN = Lty Neu 2\<close> by auto
qed auto

abbreviation "lof_wline tw sig t \<equiv> lval_of (wline_of tw sig t)"

abbreviation property :: "nat \<times> sig worldline_init \<Rightarrow> nat \<Rightarrow> bool" where
  "property tw i \<equiv> bl_to_bin (lof_wline tw OUT (i + 1)) = 2 ^ nat (bl_to_bin (lof_wline tw IN i))"

definition dec_inv :: "sig assn2" where
  "dec_inv \<equiv> \<lambda>tw. (\<forall>i < fst tw. property tw i)"

definition dec_inv2 :: "sig assn2" where
  "dec_inv2 \<equiv> \<lambda>tw. disjnt {IN} (event_of tw) \<longrightarrow>
                 (\<forall>i \<ge> fst tw.  bl_to_bin (lof_wline tw OUT (i + 1)) = 2 ^ nat (bl_to_bin (lof_wline tw IN (fst tw))))"

abbreviation "ntime tw \<equiv> next_time_world tw"

(*TODO: Move! *)
lemma invariant_cases_3:
  assumes "\<And>i. i < fst tw \<Longrightarrow> P i"
  assumes "\<And>i. fst tw \<le> i \<and> i < next_time_world tw - dly \<Longrightarrow> P i"
  assumes "\<And>i. next_time_world tw - dly \<le> i \<and> i < next_time_world tw \<Longrightarrow> P i"
  shows "\<forall>i. i < next_time_world tw \<longrightarrow> P i"
  using assms not_le_imp_less by blast

lemma invariant_cases_2:
  assumes "\<And>i. i < fst tw \<Longrightarrow> P i"
  assumes "\<And>i. fst tw \<le> i \<and> i < next_time_world tw  \<Longrightarrow> P i"
  shows "\<forall>i. i < next_time_world tw \<longrightarrow> P i"
  using assms not_le_imp_less by blast

lemma curr_time_does_not_change:
  fixes tw sig dly v
  defines "tw' \<equiv> tw [sig , dly :=\<^sub>2 v]"
  shows   "fst tw' = fst tw"
  using assms  by (simp add: worldline_upd2_def)

lemma wline_before_ntime_unchange:
  fixes tw sig dly v
  defines "tw' \<equiv> tw [sig , dly :=\<^sub>2 v]"
  shows "\<forall>i < fst tw'. wline_of tw' sig' i = wline_of tw sig' i"
  using assms by (metis curr_time_does_not_change trans_less_add1 worldline_upd2_before_dly)

lemma wline_before_ntime_unchange':
  fixes tw sig dly v
  defines "tw' \<equiv> tw [sig , dly :=\<^sub>2 v]"
  assumes "0 < dly"
  shows "\<forall>i \<le> fst tw'. wline_of tw' sig' i = wline_of tw sig' i"
  using assms  by (metis curr_time_does_not_change less_add_same_cancel1 order.not_eq_order_implies_strict
  wline_before_ntime_unchange worldline_upd2_before_dly)

lemma value_at_next_time_is_suc_time:
  fixes tw sig dly v
  defines "tw' \<equiv> tw [sig, 1 :=\<^sub>2 v]"
  shows   "wline_of tw' sig (ntime tw') = wline_of tw' sig (fst tw' + 1)"
  using assms
  by (smt Suc_eq_plus1 comp_def curr_time_does_not_change le_Suc_eq less_imp_le_nat
      next_time_world_at_least not_less snd_conv worldline_upd2_def worldline_upd_def)

lemma case0:
  assumes "dec_inv tw"
  assumes "beval_world_raw2 tw (Bsig IN) x" and "beval_world_raw2 tw (Bliteral Neu (to_bl (0 :: 2 word))) x"
  assumes "beval_world_raw2 tw (Bliteral Neu (to_bl (1 :: 4 word))) v"
  defines "tw' \<equiv> tw[ OUT, 1 :=\<^sub>2 v]"
  shows   "\<forall>j \<in> {fst tw' <.. next_time_world tw'}. dec_inv (j, snd tw')"
proof (rule)+
  fix j
  assume "j \<in> {fst tw' <.. next_time_world tw'}"
  have "beval_world_raw (snd tw) (fst tw) (Bsig IN) x" and "beval_world_raw (snd tw) (fst tw) (Bliteral Neu (to_bl (0 :: 2 word))) x"
    using assms unfolding beval_world_raw2_def by auto
  hence "x = Lv Neu (to_bl (0 :: 2 word))"
    by auto
  have v_def: "v = Lv Neu (to_bl (1 :: 4 word))"
    using assms(4) unfolding beval_world_raw2_def by auto
  have "\<forall>i<j. bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) = 2 ^ nat (bl_to_bin (lof_wline (j, snd tw') IN i))"
  proof (rule)+
    fix i
    assume "i < j"
    hence "i < fst tw' \<or> fst tw' \<le> i \<and> i < j"
      using not_less by blast
    moreover
    { assume "i < fst tw'"
      hence  "i < fst tw"
        unfolding tw'_def curr_time_does_not_change by auto
      have "2 ^ nat (bl_to_bin (lof_wline (j, snd tw') IN i)) =
            2 ^ nat (bl_to_bin (lof_wline (ntime tw , snd tw ) IN i))"
        by (metis \<open>i < get_time tw'\<close> comp_apply sndI tw'_def wline_before_ntime_unchange)
      moreover have "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) =
                     bl_to_bin (lof_wline (ntime tw , snd tw ) OUT (i + 1))"
        by (metis \<open>i < get_time tw'\<close> comp_apply discrete sndI tw'_def wline_before_ntime_unchange'
        zero_less_one)
      ultimately have "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) = 2 ^ nat (bl_to_bin (lof_wline (j, snd tw') IN i))"
        using assms(1) unfolding dec_inv_def by (smt \<open>i < get_time tw\<close> comp_apply snd_conv) }
    moreover
    { assume "fst tw' \<le> i \<and> i < j"
      hence "fst tw' \<le> i" and "i < j"
        by auto
      have "i + 1 < j \<or> i + 1 = j"
        using \<open>get_time tw' \<le> i \<and> i < j\<close> by linarith
      moreover
      { assume "i + 1 < j"
        hence "lof_wline (j, snd tw') OUT (i + 1) =
               lof_wline (j, snd tw') OUT (fst tw' + 1)"
          using unchanged_until_next_time_world  \<open>fst tw' \<le> i\<close>
          by (simp add: tw'_def worldline_upd2_def worldline_upd_def)
        also have "... = lof_wline (j, snd tw') OUT (fst tw + 1)"
          by (simp add: tw'_def worldline_upd2_def)
        finally have "lof_wline (j, snd tw') OUT (i + 1) = lof_wline (j, snd tw') OUT (fst tw + 1)"
          by auto }
      moreover
      { assume "i + 1 = j"
        hence "lof_wline (j, snd tw') OUT (i + 1) = lof_wline (j, snd tw') OUT (j)"
          by auto
        also have "... = lof_wline (j, snd tw') OUT (fst tw' + 1)"
          by (smt \<open>get_time tw' \<le> i\<close> calculation comp_apply curr_time_does_not_change discrete
          not_less sndI tw'_def worldline_upd2_at_dly worldline_upd2_def worldline_upd_def)
        also have "... = lof_wline (j, snd tw') OUT (fst tw + 1)"
          by (simp add: tw'_def worldline_upd2_def)
        finally have "lof_wline (j, snd tw') OUT (i + 1) = lof_wline (j, snd tw') OUT (fst tw + 1)"
          by auto }
      ultimately have "lof_wline (j, snd tw') OUT (i + 1) = lof_wline (j, snd tw') OUT (fst tw + 1)"
      by auto
      also have "... = lval_of v"
        by (metis comp_def snd_conv tw'_def worldline_upd2_at_dly)
      also have "... = to_bl (1 :: 4 word)"
        using v_def by auto
      finally have "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) = 1"
        by auto
      have "lof_wline (j, snd tw') IN i = lof_wline (j, snd tw') IN (fst tw')"
        using unchanged_until_next_time_world
        by (metis (mono_tags, lifting) \<open>get_time tw' \<le> i \<and> i < j\<close> \<open>j \<in> {get_time tw'<..ntime tw'}\<close> comp_cong greaterThanAtMost_iff less_le_trans snd_conv)
      also have "... = lof_wline (j, snd tw') IN (fst tw)"
        by (simp add: tw'_def worldline_upd2_def)
      also have "... = lof_wline tw IN (fst tw)"
        by (metis comp_apply less_add_one snd_conv tw'_def worldline_upd2_before_dly)
      also have "... = to_bl (0 :: 2 word)"
        by (metis \<open>beval_world_raw (snd tw) (get_time tw) (Bsig IN) x\<close> \<open>x = Lv Neu (to_bl 0)\<close>
        beval_cases(1) beval_world_raw_cases comp_apply state_of_world_def val.sel(3))
      finally have "bl_to_bin (lof_wline (j, snd tw') IN i) = 0"
        by auto
      have "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) = 2 ^ nat (bl_to_bin (lof_wline (j, snd tw') IN i))"
        using \<open>bl_to_bin (lof_wline (j, snd tw') IN i) = 0\<close> \<open>bl_to_bin (lof_wline (j,
        snd tw') OUT (i + 1)) = 1\<close> by auto }
    ultimately show "property (j, snd tw') i"
      by auto
  qed
  thus "dec_inv (j, snd tw')"
    unfolding dec_inv_def by auto
qed

lemma case1:
  assumes "dec_inv tw"
  assumes "beval_world_raw2 tw (Bsig IN) x" and "beval_world_raw2 tw (Bliteral Neu (to_bl (1 :: 2 word))) x"
  assumes "beval_world_raw2 tw (Bliteral Neu (to_bl (2 :: 4 word))) v"
  defines "tw' \<equiv> tw[ OUT, 1 :=\<^sub>2 v]"
  shows   "\<forall>j \<in> {fst tw' <.. next_time_world tw'}. dec_inv (j, snd tw')"
proof (rule)+
  fix j
  assume "j \<in> {fst tw' <.. next_time_world tw'}"
  have "beval_world_raw (snd tw) (fst tw) (Bsig IN) x" and "beval_world_raw (snd tw) (fst tw) (Bliteral Neu (to_bl (1 :: 2 word))) x"
    using assms unfolding beval_world_raw2_def by auto
  hence "x = Lv Neu (to_bl (1 :: 2 word))"
    by auto
  have v_def: "v = Lv Neu (to_bl (2 :: 4 word))"
    using assms(4) unfolding beval_world_raw2_def by auto
  have "\<forall>i<j. bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) = 2 ^ nat (bl_to_bin (lof_wline (j, snd tw') IN i))"
  proof (rule)+
    fix i
    assume "i < j"
    hence "i < fst tw' \<or> fst tw' \<le> i \<and> i < j"
      using not_less by blast
    moreover
    { assume "i < fst tw'"
      hence  "i < fst tw"
        unfolding tw'_def curr_time_does_not_change by auto
      have "2 ^ nat (bl_to_bin (lof_wline (j, snd tw') IN i)) =
            2 ^ nat (bl_to_bin (lof_wline (ntime tw , snd tw ) IN i))"
        by (metis \<open>i < get_time tw'\<close> comp_apply sndI tw'_def wline_before_ntime_unchange)
      moreover have "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) =
                     bl_to_bin (lof_wline (ntime tw , snd tw ) OUT (i + 1))"
        by (metis \<open>i < get_time tw'\<close> comp_apply discrete sndI tw'_def wline_before_ntime_unchange'
        zero_less_one)
      ultimately have "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) = 2 ^ nat (bl_to_bin (lof_wline (j, snd tw') IN i))"
        using assms(1) unfolding dec_inv_def by (smt \<open>i < get_time tw\<close> comp_apply snd_conv) }
    moreover
    { assume "fst tw' \<le> i \<and> i < j"
      hence "fst tw' \<le> i" and "i < j"
        by auto
      have "i + 1 < j \<or> i + 1 = j"
        using \<open>get_time tw' \<le> i \<and> i < j\<close> by linarith
      moreover
      { assume "i + 1 < j"
        hence "lof_wline (j, snd tw') OUT (i + 1) =
               lof_wline (j, snd tw') OUT (fst tw' + 1)"
          using unchanged_until_next_time_world  \<open>fst tw' \<le> i\<close>
          by (simp add: tw'_def worldline_upd2_def worldline_upd_def)
        also have "... = lof_wline (j, snd tw') OUT (fst tw + 1)"
          by (simp add: tw'_def worldline_upd2_def)
        finally have "lof_wline (j, snd tw') OUT (i + 1) = lof_wline (j, snd tw') OUT (fst tw + 1)"
          by auto }
      moreover
      { assume "i + 1 = j"
        hence "lof_wline (j, snd tw') OUT (i + 1) = lof_wline (j, snd tw') OUT (j)"
          by auto
        also have "... = lof_wline (j, snd tw') OUT (fst tw' + 1)"
          by (smt \<open>get_time tw' \<le> i\<close> calculation comp_apply curr_time_does_not_change discrete
          not_less sndI tw'_def worldline_upd2_at_dly worldline_upd2_def worldline_upd_def)
        also have "... = lof_wline (j, snd tw') OUT (fst tw + 1)"
          by (simp add: tw'_def worldline_upd2_def)
        finally have "lof_wline (j, snd tw') OUT (i + 1) = lof_wline (j, snd tw') OUT (fst tw + 1)"
          by auto }
      ultimately have "lof_wline (j, snd tw') OUT (i + 1) = lof_wline (j, snd tw') OUT (fst tw + 1)"
      by auto
      also have "... = lval_of v"
        by (metis comp_def snd_conv tw'_def worldline_upd2_at_dly)
      also have "... = to_bl (2 :: 4 word)"
        using v_def by auto
      finally have "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) = 2"
        by auto eval
      have "lof_wline (j, snd tw') IN i = lof_wline (j, snd tw') IN (fst tw')"
        using unchanged_until_next_time_world
        by (metis (mono_tags, lifting) \<open>get_time tw' \<le> i \<and> i < j\<close> \<open>j \<in> {get_time tw'<..ntime tw'}\<close> comp_cong greaterThanAtMost_iff less_le_trans snd_conv)
      also have "... = lof_wline (j, snd tw') IN (fst tw)"
        by (simp add: tw'_def worldline_upd2_def)
      also have "... = lof_wline tw IN (fst tw)"
        by (metis comp_apply less_add_one snd_conv tw'_def worldline_upd2_before_dly)
      also have "... = to_bl (1 :: 2 word)"
        by (metis \<open>beval_world_raw (snd tw) (get_time tw) (Bsig IN) x\<close> \<open>x = Lv Neu (to_bl 1)\<close>
        beval_cases(1) beval_world_raw_cases comp_apply state_of_world_def val.sel(3))
      finally have "bl_to_bin (lof_wline (j, snd tw') IN i) = 1"
        by auto
      have "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) = 2 ^ nat (bl_to_bin (lof_wline (j, snd tw') IN i))"
        using \<open>bl_to_bin (lof_wline (j, snd tw') IN i) = 1\<close> \<open>bl_to_bin (lof_wline (j,
        snd tw') OUT (i + 1)) = 2\<close> by auto }
    ultimately show "property (j, snd tw') i"
      by auto
  qed
  thus "dec_inv (j, snd tw')"
    unfolding dec_inv_def by auto
qed

lemma case2:
  assumes "dec_inv tw"
  assumes "beval_world_raw2 tw (Bsig IN) x" and "beval_world_raw2 tw (Bliteral Neu (to_bl (2 :: 2 word))) x"
  assumes "beval_world_raw2 tw (Bliteral Neu (to_bl (4 :: 4 word))) v"
  defines "tw' \<equiv> tw[ OUT, 1 :=\<^sub>2 v]"
  shows   "\<forall>j \<in> {fst tw' <.. next_time_world tw'}. dec_inv (j, snd tw')"
proof (rule)+
  fix j
  assume "j \<in> {fst tw' <.. next_time_world tw'}"
  have "beval_world_raw (snd tw) (fst tw) (Bsig IN) x" and "beval_world_raw (snd tw) (fst tw) (Bliteral Neu (to_bl (2 :: 2 word))) x"
    using assms unfolding beval_world_raw2_def by auto
  hence "x = Lv Neu (to_bl (2 :: 2 word))"
    by auto
  have v_def: "v = Lv Neu (to_bl (4 :: 4 word))"
    using assms(4) unfolding beval_world_raw2_def by auto
  have "\<forall>i<j. bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) = 2 ^ nat (bl_to_bin (lof_wline (j, snd tw') IN i))"
  proof (rule)+
    fix i
    assume "i < j"
    hence "i < fst tw' \<or> fst tw' \<le> i \<and> i < j"
      using not_less by blast
    moreover
    { assume "i < fst tw'"
      hence  "i < fst tw"
        unfolding tw'_def curr_time_does_not_change by auto
      have "2 ^ nat (bl_to_bin (lof_wline (j, snd tw') IN i)) =
            2 ^ nat (bl_to_bin (lof_wline (ntime tw , snd tw ) IN i))"
        by (metis \<open>i < get_time tw'\<close> comp_apply sndI tw'_def wline_before_ntime_unchange)
      moreover have "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) =
                     bl_to_bin (lof_wline (ntime tw , snd tw ) OUT (i + 1))"
        by (metis \<open>i < get_time tw'\<close> comp_apply discrete sndI tw'_def wline_before_ntime_unchange'
        zero_less_one)
      ultimately have "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) = 2 ^ nat (bl_to_bin (lof_wline (j, snd tw') IN i))"
        using assms(1) unfolding dec_inv_def by (smt \<open>i < get_time tw\<close> comp_apply snd_conv) }
    moreover
    { assume "fst tw' \<le> i \<and> i < j"
      hence "fst tw' \<le> i" and "i < j"
        by auto
      have "i + 1 < j \<or> i + 1 = j"
        using \<open>get_time tw' \<le> i \<and> i < j\<close> by linarith
      moreover
      { assume "i + 1 < j"
        hence "lof_wline (j, snd tw') OUT (i + 1) =
               lof_wline (j, snd tw') OUT (fst tw' + 1)"
          using unchanged_until_next_time_world  \<open>fst tw' \<le> i\<close>
          by (simp add: tw'_def worldline_upd2_def worldline_upd_def)
        also have "... = lof_wline (j, snd tw') OUT (fst tw + 1)"
          by (simp add: tw'_def worldline_upd2_def)
        finally have "lof_wline (j, snd tw') OUT (i + 1) = lof_wline (j, snd tw') OUT (fst tw + 1)"
          by auto }
      moreover
      { assume "i + 1 = j"
        hence "lof_wline (j, snd tw') OUT (i + 1) = lof_wline (j, snd tw') OUT (j)"
          by auto
        also have "... = lof_wline (j, snd tw') OUT (fst tw' + 1)"
          by (smt \<open>get_time tw' \<le> i\<close> calculation comp_apply curr_time_does_not_change discrete
          not_less sndI tw'_def worldline_upd2_at_dly worldline_upd2_def worldline_upd_def)
        also have "... = lof_wline (j, snd tw') OUT (fst tw + 1)"
          by (simp add: tw'_def worldline_upd2_def)
        finally have "lof_wline (j, snd tw') OUT (i + 1) = lof_wline (j, snd tw') OUT (fst tw + 1)"
          by auto }
      ultimately have "lof_wline (j, snd tw') OUT (i + 1) = lof_wline (j, snd tw') OUT (fst tw + 1)"
      by auto
      also have "... = lval_of v"
        by (metis comp_def snd_conv tw'_def worldline_upd2_at_dly)
      also have "... = to_bl (4 :: 4 word)"
        using v_def by auto
      finally have "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) = 4"
        by auto eval
      have "lof_wline (j, snd tw') IN i = lof_wline (j, snd tw') IN (fst tw')"
        using unchanged_until_next_time_world
        by (metis (mono_tags, lifting) \<open>get_time tw' \<le> i \<and> i < j\<close> \<open>j \<in> {get_time tw'<..ntime tw'}\<close> comp_cong greaterThanAtMost_iff less_le_trans snd_conv)
      also have "... = lof_wline (j, snd tw') IN (fst tw)"
        by (simp add: tw'_def worldline_upd2_def)
      also have "... = lof_wline tw IN (fst tw)"
        by (metis comp_apply less_add_one snd_conv tw'_def worldline_upd2_before_dly)
      also have "... = to_bl (2 :: 2 word)"
        by (metis \<open>beval_world_raw (snd tw) (get_time tw) (Bsig IN) x\<close> \<open>x = Lv Neu (to_bl 2)\<close>
        beval_cases(1) beval_world_raw_cases comp_apply state_of_world_def val.sel(3))
      finally have "bl_to_bin (lof_wline (j, snd tw') IN i) = 2"
        by auto eval
      have "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) = 2 ^ nat (bl_to_bin (lof_wline (j, snd tw') IN i))"
        using \<open>bl_to_bin (lof_wline (j, snd tw') IN i) = 2\<close> \<open>bl_to_bin (lof_wline (j,
        snd tw') OUT (i + 1)) = 4\<close> by auto }
    ultimately show "property (j, snd tw') i"
      by auto
  qed
  thus "dec_inv (j, snd tw')"
    unfolding dec_inv_def by auto
qed

lemma case3:
  assumes "dec_inv tw"
  assumes "beval_world_raw2 tw (Bsig IN) x" and "beval_world_raw2 tw (Bliteral Neu (to_bl (3 :: 2 word))) x"
  assumes "beval_world_raw2 tw (Bliteral Neu (to_bl (8 :: 4 word))) v"
  defines "tw' \<equiv> tw[ OUT, 1 :=\<^sub>2 v]"
  shows   "\<forall>j \<in> {fst tw' <.. next_time_world tw'}. dec_inv (j, snd tw')"
proof (rule)+
  fix j
  assume "j \<in> {fst tw' <.. next_time_world tw'}"
  have "beval_world_raw (snd tw) (fst tw) (Bsig IN) x" and "beval_world_raw (snd tw) (fst tw) (Bliteral Neu (to_bl (3 :: 2 word))) x"
    using assms unfolding beval_world_raw2_def by auto
  hence "x = Lv Neu (to_bl (3 :: 2 word))"
    by auto
  have v_def: "v = Lv Neu (to_bl (8 :: 4 word))"
    using assms(4) unfolding beval_world_raw2_def by auto
  have "\<forall>i<j. bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) = 2 ^ nat (bl_to_bin (lof_wline (j, snd tw') IN i))"
  proof (rule)+
    fix i
    assume "i < j"
    hence "i < fst tw' \<or> fst tw' \<le> i \<and> i < j"
      using not_less by blast
    moreover
    { assume "i < fst tw'"
      hence  "i < fst tw"
        unfolding tw'_def curr_time_does_not_change by auto
      have "2 ^ nat (bl_to_bin (lof_wline (j, snd tw') IN i)) =
            2 ^ nat (bl_to_bin (lof_wline (ntime tw , snd tw ) IN i))"
        by (metis \<open>i < get_time tw'\<close> comp_apply sndI tw'_def wline_before_ntime_unchange)
      moreover have "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) =
                     bl_to_bin (lof_wline (ntime tw , snd tw ) OUT (i + 1))"
        by (metis \<open>i < get_time tw'\<close> comp_apply discrete sndI tw'_def wline_before_ntime_unchange'
        zero_less_one)
      ultimately have "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) = 2 ^ nat (bl_to_bin (lof_wline (j, snd tw') IN i))"
        using assms(1) unfolding dec_inv_def by (smt \<open>i < get_time tw\<close> comp_apply snd_conv) }
    moreover
    { assume "fst tw' \<le> i \<and> i < j"
      hence "fst tw' \<le> i" and "i < j"
        by auto
      have "i + 1 < j \<or> i + 1 = j"
        using \<open>get_time tw' \<le> i \<and> i < j\<close> by linarith
      moreover
      { assume "i + 1 < j"
        hence "lof_wline (j, snd tw') OUT (i + 1) =
               lof_wline (j, snd tw') OUT (fst tw' + 1)"
          using unchanged_until_next_time_world  \<open>fst tw' \<le> i\<close>
          by (simp add: tw'_def worldline_upd2_def worldline_upd_def)
        also have "... = lof_wline (j, snd tw') OUT (fst tw + 1)"
          by (simp add: tw'_def worldline_upd2_def)
        finally have "lof_wline (j, snd tw') OUT (i + 1) = lof_wline (j, snd tw') OUT (fst tw + 1)"
          by auto }
      moreover
      { assume "i + 1 = j"
        hence "lof_wline (j, snd tw') OUT (i + 1) = lof_wline (j, snd tw') OUT (j)"
          by auto
        also have "... = lof_wline (j, snd tw') OUT (fst tw' + 1)"
          by (smt \<open>get_time tw' \<le> i\<close> calculation comp_apply curr_time_does_not_change discrete
          not_less sndI tw'_def worldline_upd2_at_dly worldline_upd2_def worldline_upd_def)
        also have "... = lof_wline (j, snd tw') OUT (fst tw + 1)"
          by (simp add: tw'_def worldline_upd2_def)
        finally have "lof_wline (j, snd tw') OUT (i + 1) = lof_wline (j, snd tw') OUT (fst tw + 1)"
          by auto }
      ultimately have "lof_wline (j, snd tw') OUT (i + 1) = lof_wline (j, snd tw') OUT (fst tw + 1)"
      by auto
      also have "... = lval_of v"
        by (metis comp_def snd_conv tw'_def worldline_upd2_at_dly)
      also have "... = to_bl (8 :: 4 word)"
        using v_def by auto
      finally have "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) = 8"
        by auto eval
      have "lof_wline (j, snd tw') IN i = lof_wline (j, snd tw') IN (fst tw')"
        using unchanged_until_next_time_world
        by (metis (mono_tags, lifting) \<open>get_time tw' \<le> i \<and> i < j\<close> \<open>j \<in> {get_time tw'<..ntime tw'}\<close> comp_cong greaterThanAtMost_iff less_le_trans snd_conv)
      also have "... = lof_wline (j, snd tw') IN (fst tw)"
        by (simp add: tw'_def worldline_upd2_def)
      also have "... = lof_wline tw IN (fst tw)"
        by (metis comp_apply less_add_one snd_conv tw'_def worldline_upd2_before_dly)
      also have "... = to_bl (3 :: 2 word)"
        by (metis \<open>beval_world_raw (snd tw) (get_time tw) (Bsig IN) x\<close> \<open>x = Lv Neu (to_bl 3)\<close>
        beval_cases(1) beval_world_raw_cases comp_apply state_of_world_def val.sel(3))
      finally have "bl_to_bin (lof_wline (j, snd tw') IN i) = 3"
        by auto eval
      have "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) = 2 ^ nat (bl_to_bin (lof_wline (j, snd tw') IN i))"
        using \<open>bl_to_bin (lof_wline (j, snd tw') IN i) = 3\<close> \<open>bl_to_bin (lof_wline (j,
        snd tw') OUT (i + 1)) = 8\<close> by auto }
    ultimately show "property (j, snd tw') i"
      by auto
  qed
  thus "dec_inv (j, snd tw')"
    unfolding dec_inv_def by auto
qed

lemma case_exhaustive:
  assumes "wityping \<Gamma> (snd tw)"
  assumes "\<Gamma> IN = Lty Neu 2"
  assumes "beval_world_raw2 tw (Bsig IN) x"
  shows   "x = Lv Neu [False, False] \<or> x = Lv Neu [False, True]  \<or> x = Lv Neu [True, False] \<or> x = Lv Neu [True, True]"
proof -
  have "beval_world_raw (snd tw) (fst tw) (Bsig IN) x"
    using assms(3) unfolding beval_world_raw2_def by auto
  have "type_of x = Lty Neu 2"
    by (metis (no_types, hide_lams) assms(1) assms(2) assms(3) beval_cases(1) beval_world_raw2_def
    beval_world_raw_cases state_of_world_def wityping_def wtyping_def)
  obtain xs where "x = Lv Neu xs" and "length xs = 2"
    by (metis \<open>type_of x = Lty Neu 2\<close> ty.distinct(1) ty.inject type_of.elims)
  have "xs = [False, False] \<or> xs = [False, True] \<or> xs = [True, False] \<or> xs = [True, True]"
    using \<open>length xs = 2\<close>
  proof (induction xs)
    case Nil
    then show ?case by auto
  next
    case (Cons a xs)
    have "a = True \<or> a = False"
      by auto
    hence "length xs = 1"
      using Cons by auto
    hence "xs = [True] \<or> xs = [False]"
      by (metis (full_types) One_nat_def length_0_conv length_Suc_conv)
    then show ?case
      using \<open>a = True \<or> a = False\<close> by auto
  qed
  thus ?thesis
    by (simp add: \<open>x = Lv Neu xs\<close>)
qed

lemma dead_code:
  assumes "wityping \<Gamma> (snd tw) "
  assumes "\<Gamma> IN = Lty Neu 2"
  assumes "x \<noteq> x' "
  assumes "beval_world_raw2 tw (Bsig IN) x "
  assumes "beval_world_raw2 tw (Bliteral Neu [False, False]) x' "
  assumes "xa \<noteq> x'a "
  assumes "beval_world_raw2 tw (Bsig IN) xa "
  assumes "beval_world_raw2 tw (Bliteral Neu [False, True]) x'a "
  assumes "xb \<noteq> x'b "
  assumes "beval_world_raw2 tw (Bsig IN) xb "
  assumes "beval_world_raw2 tw (Bliteral Neu [True, False]) x'b "
  assumes "xc \<noteq> x'c "
  assumes "beval_world_raw2 tw (Bsig IN) xc "
  assumes "beval_world_raw2 tw (Bliteral Neu [True, True]) x'c"
  shows   "False"
  using case_exhaustive[OF assms(1-2)] assms beval_world_raw2_deterministic
  by (metis beval_cases(21) beval_world_raw2_def beval_world_raw_cases)

lemma one_encoding:
  "to_bl (1 :: 2 word) = [False, True]"
  by eval

theorem dec_inv_preserved_seq:
  assumes "seq_wt \<Gamma> (Bcase (Bsig IN) dec_list)"
  shows "\<turnstile> [\<lambda>tw. dec_inv tw \<and> wityping \<Gamma> (snd tw)]  Bcase (Bsig IN) dec_list [\<lambda>tw. \<forall>j \<in> {fst tw <.. next_time_world tw}. dec_inv (j, snd tw)]"
  apply (rule Conseq2[where Q="\<lambda>tw. \<forall>j \<in> {fst tw <.. next_time_world tw}. dec_inv (j, snd tw)", rotated])
  apply (rule wp_is_pre, simp, simp)
  unfolding wp_bcase_explicit wp_bcase_empty One_nat_def wp_trans[OF lessI]
  using case0 case1 case2 case3 dead_code potential_tyenv[OF assms] one_encoding
  by fastforce

lemma dec_inv_preserved_seq0:
  assumes "seq_wt \<Gamma> (Bcase (Bsig IN) dec_list)"
  shows   " \<turnstile> [\<lambda>tw. get_time tw = 0 \<and> wityping \<Gamma> (snd tw)] Bcase (Bsig IN) dec_list [\<lambda>tw. dec_inv (next_time_world tw, snd tw) \<and> wityping \<Gamma> (snd tw)]"
  apply (rule Conj)
  apply (rule Conseq2[where P="\<lambda>tw. dec_inv tw \<and> wityping \<Gamma> (snd tw)" and Q="\<lambda>tw. \<forall>j \<in> {fst tw <.. next_time_world tw}. dec_inv (j, snd tw)"])
  using dec_inv_preserved_seq[OF assms] apply (simp add: dec_inv_def)
  apply (rule dec_inv_preserved_seq[OF assms])
   apply (simp add: next_time_world_at_least)
  apply (rule strengthen_precondition2)
  apply (rule seq_stmt_preserve_wityping_hoare[OF assms])
  done

lemma case0_inv2:
  assumes "beval_world_raw2 tw (Bsig IN) x" and "beval_world_raw2 tw (Bliteral Neu (to_bl (0 :: 2 word))) x"
  assumes "beval_world_raw2 tw (Bliteral Neu (to_bl (1 :: 4 word))) v"
  defines "tw' \<equiv> tw[ OUT, 1 :=\<^sub>2 v]"
  shows   "\<forall>j \<in> {fst tw' <.. next_time_world tw'}. dec_inv2 (j, snd tw')"
  unfolding dec_inv2_def
proof (rule)+
  fix i j
  assume "j \<in> {fst tw' <.. next_time_world tw'}"
  assume dis: "disjnt {IN} (event_of (j, snd tw'))"
  assume "fst (j, snd tw') \<le> i"
  hence "j \<le> i"
    by auto
  have "fst tw < j"
    by (metis \<open>j \<in> {get_time tw'<..ntime tw'}\<close> curr_time_does_not_change greaterThanAtMost_iff tw'_def)
  hence "0 < fst (j, snd tw')"
    by auto
  have "wline_of tw' IN (j) = wline_of tw' IN (j - 1)"
    using dis using event_of_alt_def1[OF \<open>0 < fst (j, snd tw')\<close>] by auto
  also have "... = wline_of tw' IN (fst tw')"
    by (metis (no_types, hide_lams) Suc_eq_plus1 \<open>0 < get_time (j, snd tw')\<close> \<open>j \<in> {get_time
    tw'<..ntime tw'}\<close> add_le_imp_le_diff antisym_conv1 calculation diff_le_self fst_conv
    greaterThanAtMost_iff minus_eq not_less_eq_eq order.strict_implies_order
    order_class.order.antisym unchanged_until_next_time_world zero_less_iff_neq_zero zero_neq_one)
  also have "... = wline_of tw' IN (fst tw)"
    by (simp add: curr_time_does_not_change tw'_def)
  also have "... = wline_of tw IN (fst tw)"
    by (metis less_add_one tw'_def worldline_upd2_before_dly)
  also have "... = x"
    using assms(2) unfolding beval_world_raw2_def
    by (meson assms(1) beval_world_raw2_Bsig beval_world_raw2_deterministic)
  also have "... = Lv Neu (to_bl (0 :: 2 word))"
    using assms(2) unfolding beval_world_raw2_def by blast
  finally have 0: "bl_to_bin (lof_wline (j, snd tw') IN (get_time (j, snd tw'))) = 0"
    by auto

  have "wline_of tw' OUT (i + 1) = v"
    using `fst tw < j`
    unfolding tw'_def worldline_upd2_def worldline_upd_def
    using \<open>get_time (j, snd tw') \<le> i\<close> \<open>get_time tw < j\<close> by auto
  also have "... = Lv Neu (to_bl (1 :: 4 word))"
    using assms(3) unfolding beval_world_raw2_def by blast
  finally have 1: "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) = 1"
    by auto

  show "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) =
        2 ^ nat (bl_to_bin (lof_wline (j, snd tw') IN (get_time (j, snd tw'))))"
    using "0" "1" by auto
qed

lemma case1_inv2:
  assumes "beval_world_raw2 tw (Bsig IN) x" and "beval_world_raw2 tw (Bliteral Neu (to_bl (1 :: 2 word))) x"
  assumes "beval_world_raw2 tw (Bliteral Neu (to_bl (2 :: 4 word))) v"
  defines "tw' \<equiv> tw[ OUT, 1 :=\<^sub>2 v]"
  shows   "\<forall>j \<in> {fst tw' <.. next_time_world tw'}. dec_inv2 (j, snd tw')"
  unfolding dec_inv2_def
proof (rule)+
  fix i j
  assume "j \<in> {fst tw' <.. next_time_world tw'}"
  assume dis: "disjnt {IN} (event_of (j, snd tw'))"
  assume "fst (j, snd tw') \<le> i"
  hence "j \<le> i"
    by auto
  have "fst tw < j"
    by (metis \<open>j \<in> {get_time tw'<..ntime tw'}\<close> curr_time_does_not_change greaterThanAtMost_iff tw'_def)
  hence "0 < fst (j, snd tw')"
    by auto
  have "wline_of tw' IN (j) = wline_of tw' IN (j - 1)"
    using dis using event_of_alt_def1[OF \<open>0 < fst (j, snd tw')\<close>] by auto
  also have "... = wline_of tw' IN (fst tw')"
    by (metis (no_types, hide_lams) Suc_eq_plus1 \<open>0 < get_time (j, snd tw')\<close> \<open>j \<in> {get_time
    tw'<..ntime tw'}\<close> add_le_imp_le_diff antisym_conv1 calculation diff_le_self fst_conv
    greaterThanAtMost_iff minus_eq not_less_eq_eq order.strict_implies_order
    order_class.order.antisym unchanged_until_next_time_world zero_less_iff_neq_zero zero_neq_one)
  also have "... = wline_of tw' IN (fst tw)"
    by (simp add: curr_time_does_not_change tw'_def)
  also have "... = wline_of tw IN (fst tw)"
    by (metis less_add_one tw'_def worldline_upd2_before_dly)
  also have "... = x"
    using assms(2) unfolding beval_world_raw2_def
    by (meson assms(1) beval_world_raw2_Bsig beval_world_raw2_deterministic)
  also have "... = Lv Neu (to_bl (1 :: 2 word))"
    using assms(2) unfolding beval_world_raw2_def by blast
  finally have 0: "bl_to_bin (lof_wline (j, snd tw') IN (get_time (j, snd tw'))) = 1"
    by auto

  have "wline_of tw' OUT (i + 1) = v"
    using `fst tw < j`
    unfolding tw'_def worldline_upd2_def worldline_upd_def
    using \<open>get_time (j, snd tw') \<le> i\<close> \<open>get_time tw < j\<close> by auto
  also have "... = Lv Neu (to_bl (2 :: 4 word))"
    using assms(3) unfolding beval_world_raw2_def by blast
  finally have 1: "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) = 2"
    by auto eval

  show "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) =
        2 ^ nat (bl_to_bin (lof_wline (j, snd tw') IN (get_time (j, snd tw'))))"
    using "0" "1" by auto
qed

lemma case2_inv2:
  assumes "beval_world_raw2 tw (Bsig IN) x" and "beval_world_raw2 tw (Bliteral Neu (to_bl (2 :: 2 word))) x"
  assumes "beval_world_raw2 tw (Bliteral Neu (to_bl (4 :: 4 word))) v"
  defines "tw' \<equiv> tw[ OUT, 1 :=\<^sub>2 v]"
  shows   "\<forall>j \<in> {fst tw' <.. next_time_world tw'}. dec_inv2 (j, snd tw')"
  unfolding dec_inv2_def
proof (rule)+
  fix i j
  assume "j \<in> {fst tw' <.. next_time_world tw'}"
  assume dis: "disjnt {IN} (event_of (j, snd tw'))"
  assume "fst (j, snd tw') \<le> i"
  hence "j \<le> i"
    by auto
  have "fst tw < j"
    by (metis \<open>j \<in> {get_time tw'<..ntime tw'}\<close> curr_time_does_not_change greaterThanAtMost_iff tw'_def)
  hence "0 < fst (j, snd tw')"
    by auto
  have "wline_of tw' IN (j) = wline_of tw' IN (j - 1)"
    using dis using event_of_alt_def1[OF \<open>0 < fst (j, snd tw')\<close>] by auto
  also have "... = wline_of tw' IN (fst tw')"
    by (metis (no_types, hide_lams) Suc_eq_plus1 \<open>0 < get_time (j, snd tw')\<close> \<open>j \<in> {get_time
    tw'<..ntime tw'}\<close> add_le_imp_le_diff antisym_conv1 calculation diff_le_self fst_conv
    greaterThanAtMost_iff minus_eq not_less_eq_eq order.strict_implies_order
    order_class.order.antisym unchanged_until_next_time_world zero_less_iff_neq_zero zero_neq_one)
  also have "... = wline_of tw' IN (fst tw)"
    by (simp add: curr_time_does_not_change tw'_def)
  also have "... = wline_of tw IN (fst tw)"
    by (metis less_add_one tw'_def worldline_upd2_before_dly)
  also have "... = x"
    using assms(2) unfolding beval_world_raw2_def
    by (meson assms(1) beval_world_raw2_Bsig beval_world_raw2_deterministic)
  also have "... = Lv Neu (to_bl (2 :: 2 word))"
    using assms(2) unfolding beval_world_raw2_def by blast
  finally have 0: "bl_to_bin (lof_wline (j, snd tw') IN (get_time (j, snd tw'))) = 2"
    by auto eval

  have "wline_of tw' OUT (i + 1) = v"
    using `fst tw < j`
    unfolding tw'_def worldline_upd2_def worldline_upd_def
    using \<open>get_time (j, snd tw') \<le> i\<close> \<open>get_time tw < j\<close> by auto
  also have "... = Lv Neu (to_bl (4 :: 4 word))"
    using assms(3) unfolding beval_world_raw2_def by blast
  finally have 1: "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) = 4"
    by auto eval

  show "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) =
        2 ^ nat (bl_to_bin (lof_wline (j, snd tw') IN (get_time (j, snd tw'))))"
    using "0" "1" by auto
qed

lemma case3_inv2:
  assumes "beval_world_raw2 tw (Bsig IN) x" and "beval_world_raw2 tw (Bliteral Neu (to_bl (3 :: 2 word))) x"
  assumes "beval_world_raw2 tw (Bliteral Neu (to_bl (8 :: 4 word))) v"
  defines "tw' \<equiv> tw[ OUT, 1 :=\<^sub>2 v]"
  shows   "\<forall>j \<in> {fst tw' <.. next_time_world tw'}. dec_inv2 (j, snd tw')"
  unfolding dec_inv2_def
proof (rule)+
  fix i j
  assume "j \<in> {fst tw' <.. next_time_world tw'}"
  assume dis: "disjnt {IN} (event_of (j, snd tw'))"
  assume "fst (j, snd tw') \<le> i"
  hence "j \<le> i"
    by auto
  have "fst tw < j"
    by (metis \<open>j \<in> {get_time tw'<..ntime tw'}\<close> curr_time_does_not_change greaterThanAtMost_iff tw'_def)
  hence "0 < fst (j, snd tw')"
    by auto
  have "wline_of tw' IN (j) = wline_of tw' IN (j - 1)"
    using dis using event_of_alt_def1[OF \<open>0 < fst (j, snd tw')\<close>] by auto
  also have "... = wline_of tw' IN (fst tw')"
    by (metis (no_types, hide_lams) Suc_eq_plus1 \<open>0 < get_time (j, snd tw')\<close> \<open>j \<in> {get_time
    tw'<..ntime tw'}\<close> add_le_imp_le_diff antisym_conv1 calculation diff_le_self fst_conv
    greaterThanAtMost_iff minus_eq not_less_eq_eq order.strict_implies_order
    order_class.order.antisym unchanged_until_next_time_world zero_less_iff_neq_zero zero_neq_one)
  also have "... = wline_of tw' IN (fst tw)"
    by (simp add: curr_time_does_not_change tw'_def)
  also have "... = wline_of tw IN (fst tw)"
    by (metis less_add_one tw'_def worldline_upd2_before_dly)
  also have "... = x"
    using assms(2) unfolding beval_world_raw2_def
    by (meson assms(1) beval_world_raw2_Bsig beval_world_raw2_deterministic)
  also have "... = Lv Neu (to_bl (3 :: 2 word))"
    using assms(2) unfolding beval_world_raw2_def by blast
  finally have 0: "bl_to_bin (lof_wline (j, snd tw') IN (get_time (j, snd tw'))) = 3"
    by auto eval

  have "wline_of tw' OUT (i + 1) = v"
    using `fst tw < j`
    unfolding tw'_def worldline_upd2_def worldline_upd_def
    using \<open>get_time (j, snd tw') \<le> i\<close> \<open>get_time tw < j\<close> by auto
  also have "... = Lv Neu (to_bl (8 :: 4 word))"
    using assms(3) unfolding beval_world_raw2_def by blast
  finally have 1: "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) = 8"
    by auto eval

  show "bl_to_bin (lof_wline (j, snd tw') OUT (i + 1)) =
        2 ^ nat (bl_to_bin (lof_wline (j, snd tw') IN (get_time (j, snd tw'))))"
    using "0" "1" by auto
qed

theorem dec_inv2_preserved_seq:
  assumes "seq_wt \<Gamma> (Bcase (Bsig IN) dec_list)"
  shows "\<turnstile> [\<lambda>tw. wityping \<Gamma> (snd tw)] Bcase (Bsig IN) dec_list [\<lambda>tw. \<forall>j \<in> {fst tw <.. next_time_world tw}. dec_inv2 (j, snd tw)]"
  apply (rule Conseq2[where Q="\<lambda>tw. \<forall>j \<in> {fst tw <.. next_time_world tw}. dec_inv2 (j, snd tw)", rotated])
  apply (rule wp_is_pre, simp, simp)
  unfolding wp_bcase_explicit wp_bcase_empty One_nat_def wp_trans[OF lessI] if_split
  using case0_inv2 case1_inv2 case2_inv2 case3_inv2 dead_code potential_tyenv[OF assms] one_encoding
  by fastforce

lemma dec_inv_preserved_disjnt:
  " \<forall>tw. dec_inv tw \<and> dec_inv2 tw \<and> disjnt {IN} (event_of tw) \<longrightarrow> (\<forall>j \<in> {fst tw <.. next_time_world tw}. dec_inv (j, snd tw))"
proof (rule)+
  fix tw :: "nat \<times> (sig \<Rightarrow> val) \<times> (sig \<Rightarrow> nat \<Rightarrow> val)"
  fix j :: nat
  assume "j \<in> {get_time tw<..ntime tw} "
  assume "dec_inv tw \<and> dec_inv2 tw \<and> disjnt {IN} (event_of tw)"
  hence "dec_inv tw" and "dec_inv2 tw" and "disjnt {IN} (event_of tw)"
    by auto
  { fix i
    assume "i < fst (j, snd tw)"
    hence "i < j"
      by auto
    have "fst tw < j"
      using \<open>j \<in> {get_time tw<..ntime tw}\<close> greaterThanAtMost_iff by blast
    have "i < fst tw \<or> fst tw \<le> i"
      by auto
    moreover
    { assume "i < fst tw"
      hence "property (j, snd tw) i"
        using \<open>dec_inv tw\<close> unfolding dec_inv_def by auto }
    moreover
    { assume "fst tw \<le> i"
      have "wline_of (j, snd tw) IN i = wline_of (j, snd tw) IN (fst tw)"
        by (metis (no_types, hide_lams) \<open>get_time tw \<le> i\<close> \<open>i < j\<close> \<open>j \<in> {get_time tw<..ntime tw}\<close>
        comp_apply dual_order.strict_trans2 greaterThanAtMost_iff not_le snd_conv
        unchanged_until_next_time_world)
      moreover have "bl_to_bin (lof_wline tw OUT (i + 1)) = 2 ^ nat (bl_to_bin (lof_wline tw IN (get_time tw)))"
        using \<open>dec_inv2 tw\<close> \<open>disjnt {IN} (event_of tw)\<close> unfolding dec_inv2_def using \<open>get_time tw \<le> i\<close>
        by blast
      ultimately have "property (j, snd tw) i"
        by simp }
    ultimately have "property (j, snd tw) i"
      by auto }
  thus "dec_inv (j, snd tw)"
    unfolding dec_inv_def by auto
qed

lemma dec_inv2_preserved_disjnt:
  "\<forall>tw. dec_inv tw \<and> dec_inv2 tw \<and> disjnt {IN} (event_of tw) \<longrightarrow> (\<forall>j \<in> {fst tw <.. next_time_world tw}. dec_inv2 (j, snd tw))"
proof (rule)+
  fix tw :: "nat \<times> (sig \<Rightarrow> val) \<times> (sig \<Rightarrow> nat \<Rightarrow> val)"
  fix j :: nat
  assume "j \<in> {fst tw <.. ntime tw}"
  assume "dec_inv tw \<and> dec_inv2 tw \<and> disjnt {IN} (event_of tw)"
  hence "dec_inv tw" and "dec_inv2 tw" and "disjnt {IN} (event_of tw)"
    by auto
  { fix i
    assume dis: "disjnt {IN} (event_of (j, snd tw))"
    assume "i \<ge> j"
    have "fst tw < j"
      using next_time_world_at_least \<open>j \<in> {get_time tw<..ntime tw}\<close> greaterThanAtMost_iff by blast
    hence *: "0 < fst (j, snd tw)"
      by auto
    have "wline_of tw IN j = wline_of tw IN (j - 1)"
      using dis unfolding event_of_alt_def1[OF *] by auto
    also have "... = wline_of tw IN (fst tw)"
      by (metis (no_types, lifting) Suc_diff_1 \<open>j \<in> {get_time tw<..ntime tw}\<close> diff_less
      dual_order.strict_implies_order dual_order.strict_trans1 greaterThanAtMost_iff le_Suc_eq
      le_zero_eq neq_iff unchanged_until_next_time_world zero_less_one)
    finally have "wline_of tw IN j = wline_of tw IN (fst tw)"
      by auto
    have "bl_to_bin (lof_wline tw OUT (i + 1)) = 2 ^ nat (bl_to_bin (lof_wline tw IN (fst tw)))"
      using \<open>dec_inv2 tw\<close> \<open>fst tw < j\<close> \<open>j \<le> i\<close> \<open>disjnt {IN} (event_of tw)\<close>
      unfolding dec_inv2_def by auto
    hence "bl_to_bin (lof_wline tw OUT (i + 1)) = 2 ^ nat (bl_to_bin (lof_wline tw IN j))"
      using \<open>wline_of tw IN j = wline_of tw IN (get_time tw)\<close>
      by auto }
  thus "dec_inv2 (j, snd tw)"
    unfolding dec_inv2_def by auto
qed

theorem conc_hoare_next_time:
  assumes "conc_wt \<Gamma> dec"
  shows
  "\<turnstile> \<lbrace>\<lambda>tw. (dec_inv tw \<and> wityping \<Gamma> (snd tw)) \<and> (dec_inv2 tw \<and> wityping \<Gamma> (snd tw))\<rbrace>
        dec
     \<lbrace>\<lambda>tw. (\<forall>j \<in> {fst tw <.. next_time_world tw}. dec_inv  (j, snd tw))  \<and> (\<forall>j \<in> {fst tw <.. next_time_world tw}. dec_inv2  (j, snd tw))\<rbrace>"
  unfolding dec_def
  apply (rule Single)
   apply (rule Conj)
    apply (rule strengthen_precondition)
    apply (rule strengthen_precondition)
  using dec_inv_preserved_seq  assms unfolding dec_def apply (meson conc_wt_cases(1))
   apply (rule strengthen_precondition)
   apply (rule strengthen_precondition2)+
  using dec_inv2_preserved_seq  assms unfolding dec_def apply (meson conc_wt_cases(1))
  using dec_inv_preserved_disjnt dec_inv2_preserved_disjnt
  by blast

theorem conc_hoare_next_time':
  assumes "conc_wt \<Gamma> dec"
  shows
  "\<turnstile> \<lbrace>\<lambda>tw. (dec_inv tw \<and> wityping \<Gamma> (snd tw)) \<and> (dec_inv2 tw \<and> wityping \<Gamma> (snd tw)) \<rbrace>
        dec
     \<lbrace>\<lambda>tw.  \<forall>j \<in> {fst tw <.. ntime tw}. (dec_inv  (j, snd tw) \<and> (wityping \<Gamma> (snd tw)))
                                      \<and> (dec_inv2 (j, snd tw) \<and>  wityping \<Gamma> (snd tw))\<rbrace>"
  apply (rule Conj2_univ_qtfd[where S="\<lambda>tw. {fst tw <.. ntime tw}" and Q="\<lambda>tw. (dec_inv (fst tw, snd tw) \<and> wityping \<Gamma> (snd tw))"
                                                             and R="\<lambda>tw.  (dec_inv2 (fst tw, snd tw) \<and> wityping \<Gamma> (snd tw))", unfolded fst_conv, unfolded snd_conv])
  apply (rule Conj2_univ_qtfd[where S="\<lambda>tw. {fst tw <.. ntime tw}" and Q="\<lambda>tw. dec_inv (fst tw, snd tw)" and R="\<lambda>tw. wityping \<Gamma> (snd tw)", unfolded fst_conv, unfolded snd_conv])
    apply (rule weaken_post_conc_hoare[rotated])
     apply (rule conc_hoare_next_time[OF assms])
    apply blast
   apply (rule Conseq'[rotated])
  unfolding dec_def apply (rule single_conc_stmt_preserve_wityping_hoare[where \<Gamma>="\<Gamma>"])
  using assms  apply (metis conc_wt_cases(1) dec_def)
    apply blast
   apply blast
  apply (rule Conj2_univ_qtfd[where S="\<lambda>tw. {fst tw <.. ntime tw}" and Q="\<lambda>tw. dec_inv2 (fst tw, snd tw)" and R="\<lambda>tw. wityping \<Gamma> (snd tw)", unfolded fst_conv, unfolded snd_conv])
   apply (rule weaken_post_conc_hoare[rotated])
    apply(rule conc_hoare_next_time[OF assms, unfolded dec_def])
   apply blast
   apply (rule Conseq'[rotated])
  unfolding dec_def apply (rule single_conc_stmt_preserve_wityping_hoare[where \<Gamma>="\<Gamma>"])
  using assms  apply (metis conc_wt_cases(1) dec_def)
  apply blast
  by blast

theorem dec_sim:
  assumes "conc_wt \<Gamma> dec"
  shows
  "\<turnstile>\<^sub>s \<lbrace>\<lambda>tw. (dec_inv tw \<and> wityping \<Gamma> (snd tw)) \<and> (dec_inv2 tw \<and> wityping \<Gamma> (snd tw)) \<rbrace>
        dec
      \<lbrace>\<lambda>tw. (dec_inv tw \<and> wityping \<Gamma> (snd tw)) \<and> (dec_inv2 tw \<and> wityping \<Gamma> (snd tw))\<rbrace>"
  apply (rule While)
  unfolding snd_conv
  by (rule conc_hoare_next_time'[OF assms])

lemma init_sat_dec_inv:
  assumes "seq_wt \<Gamma> (Bcase (Bsig IN) dec_list)"
  shows "init_sim_hoare (\<lambda>tw. fst tw = 0 \<and> wityping \<Gamma> (snd tw)) dec (\<lambda>tw. dec_inv tw \<and> wityping \<Gamma> (snd tw))"
  unfolding dec_def
  apply (rule AssignI)
  apply (rule SingleI)
  unfolding snd_conv apply(rule dec_inv_preserved_seq0[OF assms])
  done

lemma init_sat_dec_inv2:
  assumes "seq_wt \<Gamma> (Bcase (Bsig IN) dec_list)"
  shows "init_sim_hoare (\<lambda>tw. wityping \<Gamma> (snd tw)) dec (\<lambda>tw. dec_inv2 tw \<and> wityping \<Gamma> (snd tw))"
  unfolding dec_def
  apply (rule AssignI)
  apply (rule SingleI)
  apply (rule Conj)
  apply (rule Conseq2[rotated])
     apply (rule dec_inv2_preserved_seq[OF assms])
    apply (simp add: next_time_world_at_least)
   apply simp
  unfolding snd_conv
  apply (rule seq_stmt_preserve_wityping_hoare[OF assms])
  done

lemma init_sat_dec_inv_comb:
  assumes "seq_wt \<Gamma> (Bcase (Bsig IN) dec_list)"
  shows "init_sim_hoare (\<lambda>tw. fst tw = 0 \<and> wityping \<Gamma> (snd tw)) dec (\<lambda>tw. (dec_inv tw \<and> wityping \<Gamma> (snd tw)) \<and> (dec_inv2 tw \<and> wityping \<Gamma> (snd tw)))"
  apply (rule ConjI_sim)
  apply (rule init_sat_dec_inv[OF assms])
  apply (rule ConseqI_sim[where P="\<lambda>tw. wityping \<Gamma> (snd tw)" and Q="\<lambda>tw. (dec_inv2 tw \<and> wityping \<Gamma> (snd tw))", rotated])
  apply (rule init_sat_dec_inv2[OF assms])
  by blast+

theorem
  assumes "sim_fin w (i + 1) dec tw'" and "wityping \<Gamma> w" and "conc_wt \<Gamma> dec"
  shows "bl_to_bin (lof_wline tw' OUT (i + 1)) = 2 ^ nat (bl_to_bin (lof_wline tw' IN i))"
proof -
  obtain tw where "init_sim (0, w) dec tw" and  "tw, i + 1, dec \<Rightarrow>\<^sub>S tw'"
    using premises_sim_fin_obt[OF assms(1)] by auto
  hence "i + 1 = fst tw'"
    using world_maxtime_lt_fst_tres  by blast
  have "conc_stmt_wf dec"
    unfolding conc_stmt_wf_def dec_def by auto
  moreover have "nonneg_delay_conc dec"
    unfolding dec_def by auto
  moreover have "seq_wt \<Gamma> (Bcase (Bsig IN) dec_list)"
    using assms(3)  by (metis conc_wt_cases(1) dec_def)
  ultimately have "init_sim_valid (\<lambda>tw. fst tw = 0 \<and> wityping \<Gamma> (snd tw)) dec (\<lambda>tw. (dec_inv tw \<and> wityping \<Gamma> (snd tw)) \<and> (dec_inv2 tw \<and> wityping \<Gamma> (snd tw)))"
    using init_sim_hoare_soundness[OF init_sat_dec_inv_comb] by auto
  hence "(dec_inv tw \<and> wityping \<Gamma> (snd tw)) \<and> (dec_inv2 tw \<and> wityping \<Gamma> (snd tw))"
    using \<open>init_sim (0, w) dec tw\<close> fst_conv assms(2) unfolding init_sim_valid_def
    by (metis snd_conv)
  hence "(dec_inv tw \<and> wityping \<Gamma> (snd tw))" and "(dec_inv2 tw \<and> wityping \<Gamma> (snd tw))"
    by auto
  moreover have "\<Turnstile>\<^sub>s \<lbrace>\<lambda>tw. (dec_inv tw \<and> wityping \<Gamma> (snd tw)) \<and> (dec_inv2 tw \<and> wityping \<Gamma> (snd tw))\<rbrace> dec \<lbrace>\<lambda>tw. (dec_inv tw \<and> wityping \<Gamma> (snd tw))\<rbrace>"
    using conc_sim_soundness \<open>conc_stmt_wf dec\<close> \<open>nonneg_delay_conc dec\<close>
    by (metis (no_types, lifting) assms(3) dec_sim sim_hoare_valid_def)
  ultimately have "(dec_inv tw' \<and> wityping \<Gamma> (snd tw'))"
    using \<open>tw, i + 1, dec \<Rightarrow>\<^sub>S tw'\<close> unfolding sim_hoare_valid_def by blast
  hence "\<forall>i < fst tw'. bl_to_bin (lof_wline tw' OUT (i + 1)) = 2 ^ nat (bl_to_bin (lof_wline tw' IN i))"
    unfolding dec_inv_def by auto
  with \<open>i + 1 = fst tw'\<close> show ?thesis
    by (metis less_add_one)
qed

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsubsection \<open>Basic Setup\<close>
theory Transport_Natural_Functors_Base
  imports
    HOL.BNF_Def
    HOL_Basics.HOL_Alignment_Functions
    Transport_Base
begin

paragraph \<open>Summary\<close>
text \<open>Basic setup for closure proofs and simple lemmas.\<close>

text \<open>In the following, we willingly use granular apply-style proofs since,
in practice, these theorems have to be automatically generated whenever we
declare a new natural functor.

Note that "HOL-Library" provides a command \<open>bnf_axiomatization\<close> which allows
one to axiomatically declare a bounded natural functor. However, we only need a
subset of these axioms - the boundedness of the functor is irrelevant for our
purposes. For this reason - and the sake of completeness - we state all the
required axioms explicitly below.\<close>

lemma Grp_UNIV_eq_eq_comp: "BNF_Def.Grp UNIV f = (=) \<circ> f"
  by (intro ext) (auto elim: GrpE intro: GrpI)

lemma eq_comp_rel_comp_eq_comp: "(=) \<circ> f \<circ>\<circ> R = R \<circ> f"
  by (intro ext) auto

lemma Domain_Collect_case_prod_eq_Collect_in_dom:
  "Domain {(x, y). R x y} = {x. in_dom R x}"
  by blast

lemma ball_in_dom_iff_ball_ex:
  "(\<forall>x \<in> S. in_dom R x) \<longleftrightarrow> (\<forall>x \<in> S. \<exists>y. R x y)"
  by blast

lemma pair_mem_Collect_case_prod_iff: "(x, y) \<in> {(x, y). R x y} \<longleftrightarrow> R x y"
  by blast

paragraph \<open>Natural Functor Axiomatisation\<close>

typedecl ('d, 'a, 'b, 'c) F

consts Fmap :: "('a1 \<Rightarrow> 'a2) \<Rightarrow> ('b1 \<Rightarrow> 'b2) \<Rightarrow> ('c1 \<Rightarrow> 'c2) \<Rightarrow>
    ('d, 'a1, 'b1, 'c1) F \<Rightarrow> ('d, 'a2, 'b2, 'c2) F"
  Fset1 :: "('d, 'a, 'b, 'c) F \<Rightarrow> 'a set"
  Fset2 :: "('d, 'a, 'b, 'c) F \<Rightarrow> 'b set"
  Fset3 :: "('d, 'a, 'b, 'c) F \<Rightarrow> 'c set"

axiomatization
  where Fmap_id: "Fmap id id id = id"
  and Fmap_comp: "\<And>f1 f2 f3 g1 g2 g3.
    Fmap (g1 \<circ> f1) (g2 \<circ> f2) (g3 \<circ> f3) = Fmap g1 g2 g3 \<circ> Fmap f1 f2 f3"
  and Fmap_cong: "\<And>f1 f2 f3 g1 g2 g3 x.
    (\<And>x1. x1 \<in> Fset1 x \<Longrightarrow> f1 x1 = g1 x1) \<Longrightarrow>
    (\<And>x2. x2 \<in> Fset2 x \<Longrightarrow> f2 x2 = g2 x2) \<Longrightarrow>
    (\<And>x3. x3 \<in> Fset3 x \<Longrightarrow> f3 x3 = g3 x3) \<Longrightarrow>
    Fmap f1 f2 f3 x = Fmap g1 g2 g3 x"
  and Fset1_natural: "\<And>f1 f2 f3. Fset1 \<circ> Fmap f1 f2 f3 = image f1 \<circ> Fset1"
  and Fset2_natural: "\<And>f1 f2 f3. Fset2 \<circ> Fmap f1 f2 f3 = image f2 \<circ> Fset2"
  and Fset3_natural: "\<And>f1 f2 f3. Fset3 \<circ> Fmap f1 f2 f3 = image f3 \<circ> Fset3"

lemma Fmap_id_eq_self: "Fmap id id id x = x"
  by (subst Fmap_id, subst id_eq_self, rule refl)

lemma Fmap_comp_eq_Fmap_Fmap:
  "Fmap (g1 \<circ> f1) (g2 \<circ> f2) (g3 \<circ> f3) x = Fmap g1 g2 g3 (Fmap f1 f2 f3 x)"
  by (fact fun_cong[OF Fmap_comp, simplified comp_eq])

lemma Fset1_Fmap_eq_image_Fset1: "Fset1 (Fmap f1 f2 f3 x) = f1 ` Fset1 x"
  by (fact fun_cong[OF Fset1_natural, simplified comp_eq])

lemma Fset2_Fmap_eq_image_Fset2: "Fset2 (Fmap f1 f2 f3 x) = f2 ` Fset2 x"
  by (fact fun_cong[OF Fset2_natural, simplified comp_eq])

lemma Fset3_Fmap_eq_image_Fset3: "Fset3 (Fmap f1 f2 f3 x) = f3 ` Fset3 x"
  by (fact fun_cong[OF Fset3_natural, simplified comp_eq])

lemmas Fset_Fmap_eqs = Fset1_Fmap_eq_image_Fset1 Fset2_Fmap_eq_image_Fset2
  Fset3_Fmap_eq_image_Fset3

paragraph \<open>Relator\<close>

definition Frel :: "('a1 \<Rightarrow> 'a2 \<Rightarrow> bool) \<Rightarrow> ('b1 \<Rightarrow> 'b2 \<Rightarrow> bool) \<Rightarrow> ('c1 \<Rightarrow> 'c2 \<Rightarrow> bool) \<Rightarrow>
  ('d, 'a1, 'b1, 'c1) F \<Rightarrow> ('d, 'a2, 'b2, 'c2) F \<Rightarrow> bool"
  where "Frel R1 R2 R3 x y \<equiv> (\<exists>z.
    z \<in> {x. Fset1 x \<subseteq> {(x, y). R1 x y} \<and> Fset2 x \<subseteq> {(x, y). R2 x y}
      \<and> Fset3 x \<subseteq> {(x, y). R3 x y}}
    \<and> Fmap fst fst fst z = x
    \<and> Fmap snd snd snd z = y)"

lemma FrelI:
  assumes "Fset1 z \<subseteq> {(x, y). R1 x y}"
  and "Fset2 z \<subseteq> {(x, y). R2 x y}"
  and "Fset3 z \<subseteq> {(x, y). R3 x y}"
  and "Fmap fst fst fst z = x"
  and "Fmap snd snd snd z = y"
  shows "Frel R1 R2 R3 x y"
  apply (subst Frel_def)
  apply (intro exI conjI CollectI)
  apply (fact assms)+
  done

lemma FrelE:
  assumes "Frel R1 R2 R3 x y"
  obtains z where "Fset1 z \<subseteq> {(x, y). R1 x y}" "Fset2 z \<subseteq> {(x, y). R2 x y}"
    "Fset3 z \<subseteq> {(x, y). R3 x y}" "Fmap fst fst fst z = x" "Fmap snd snd snd z = y"
  apply (insert assms)
  apply (subst (asm) Frel_def)
  apply (elim exE CollectE conjE)
  apply assumption
  done

lemma Grp_UNIV_Fmap_eq_Frel_Grp: "BNF_Def.Grp UNIV (Fmap f1 f2 f3) =
  Frel (BNF_Def.Grp UNIV f1) (BNF_Def.Grp UNIV f2) (BNF_Def.Grp UNIV f3)"
  apply (intro ext iffI)
    apply (rule FrelI[where
      ?z="Fmap (BNF_Def.convol id f1) (BNF_Def.convol id f2) (BNF_Def.convol id f3) _"])
    apply (subst Fset_Fmap_eqs,
      rule image_subsetI,
      rule convol_mem_GrpI[simplified Fun_id_eq_id],
      rule UNIV_I)+
    apply (unfold Fmap_comp_eq_Fmap_Fmap[symmetric]
      fst_convol[simplified Fun_comp_eq_comp]
      snd_convol[simplified Fun_comp_eq_comp]
      Fmap_id id_eq_self)
    apply (rule refl)
    apply (subst (asm) Grp_UNIV_eq_eq_comp)
    apply (subst (asm) comp_eq)
    apply assumption
    apply (erule FrelE)
    apply hypsubst
    apply (subst Grp_UNIV_eq_eq_comp)
    apply (subst comp_eq)
    apply (subst Fmap_comp_eq_Fmap_Fmap[symmetric])
    apply (rule Fmap_cong;
      rule Collect_case_prod_Grp_eqD[simplified Fun_comp_eq_comp],
      drule rev_subsetD,
      assumption+)
  done

lemma Frel_Grp_UNIV_Fmap:
  "Frel (BNF_Def.Grp UNIV f1) (BNF_Def.Grp UNIV f2) (BNF_Def.Grp UNIV f3)
    x (Fmap f1 f2 f3 x)"
  apply (subst Grp_UNIV_Fmap_eq_Frel_Grp[symmetric])
  apply (subst Grp_UNIV_eq_eq_comp)
  apply (subst comp_eq)
  apply (rule refl)
  done

lemma Frel_Grp_UNIV_iff_eq_Fmap:
  "Frel (BNF_Def.Grp UNIV f1) (BNF_Def.Grp UNIV f2) (BNF_Def.Grp UNIV f3) x y \<longleftrightarrow>
    (y = Fmap f1 f2 f3 x)"
  by (subst eq_commute[of y])
  (fact fun_cong[OF fun_cong[OF Grp_UNIV_Fmap_eq_Frel_Grp],
    simplified Grp_UNIV_eq_eq_comp comp_eq, folded Grp_UNIV_eq_eq_comp, symmetric])

lemma Frel_eq: "Frel (=) (=) (=) = (=)"
  apply (unfold BNF_Def.eq_alt[simplified Fun_id_eq_id])
  apply (subst Grp_UNIV_Fmap_eq_Frel_Grp[symmetric])
  apply (subst Fmap_id)
  apply (fold BNF_Def.eq_alt[simplified Fun_id_eq_id])
  apply (rule refl)
  done

corollary Frel_eq_self: "Frel (=) (=) (=) x x"
  by (fact iffD2[OF fun_cong[OF fun_cong[OF Frel_eq]] refl])

lemma Frel_mono_strong:
  assumes "Frel R1 R2 R3 x y"
  and "\<And>x1 y1. x1 \<in> Fset1 x \<Longrightarrow> y1 \<in> Fset1 y \<Longrightarrow> R1 x1 y1 \<Longrightarrow> S1 x1 y1"
  and "\<And>x2 y2. x2 \<in> Fset2 x \<Longrightarrow> y2 \<in> Fset2 y \<Longrightarrow> R2 x2 y2 \<Longrightarrow> S2 x2 y2"
  and "\<And>x3 y3. x3 \<in> Fset3 x \<Longrightarrow> y3 \<in> Fset3 y \<Longrightarrow> R3 x3 y3 \<Longrightarrow> S3 x3 y3"
  shows "Frel S1 S2 S3 x y"
  apply (insert assms(1))
  apply (erule FrelE)
  apply (rule FrelI)
    apply (rule subsetI,
      frule rev_subsetD,
      assumption,
      frule imageI[of _ "Fset1 _" fst]
        imageI[of _ "Fset2 _" fst]
        imageI[of _ "Fset3 _" fst],
      drule imageI[of _ "Fset1 _" snd]
        imageI[of _ "Fset2 _" snd]
        imageI[of _ "Fset3 _" snd],
      (subst (asm) Fset_Fmap_eqs[symmetric])+,
      intro CollectI case_prodI2,
      rule assms;
      hypsubst,
      unfold fst_conv snd_conv,
      (elim CollectE case_prodE Pair_inject, hypsubst)?,
      assumption)+
    apply assumption+
  done

corollary Frel_mono:
  assumes "R1 \<le> S1" "R2 \<le> S2" "R3 \<le> S3"
  shows "Frel R1 R2 R3 \<le> Frel S1 S2 S3"
  apply (intro le_relI)
  apply (rule Frel_mono_strong)
    apply assumption
    apply (insert assms)
    apply (drule le_relD[OF assms(1)] le_relD[OF assms(2)] le_relD[OF assms(3)],
      assumption)+
  done

lemma Frel_refl_strong:
  assumes "\<And>x1. x1 \<in> Fset1 x \<Longrightarrow> R1 x1 x1"
  and "\<And>x2. x2 \<in> Fset2 x \<Longrightarrow> R2 x2 x2"
  and "\<And>x3. x3 \<in> Fset3 x \<Longrightarrow> R3 x3 x3"
  shows "Frel R1 R2 R3 x x"
  by (rule Frel_mono_strong[OF Frel_eq_self[of x]];
    drule assms, hypsubst, assumption)

lemma Frel_cong:
  assumes "\<And>x1 y1. x1 \<in> Fset1 x \<Longrightarrow> y1 \<in> Fset1 y \<Longrightarrow> R1 x1 y1 \<longleftrightarrow> R1' x1 y1"
  and "\<And>x2 y2. x2 \<in> Fset2 x \<Longrightarrow> y2 \<in> Fset2 y \<Longrightarrow> R2 x2 y2 \<longleftrightarrow> R2' x2 y2"
  and "\<And>x3 y3. x3 \<in> Fset3 x \<Longrightarrow> y3 \<in> Fset3 y \<Longrightarrow> R3 x3 y3 \<longleftrightarrow> R3' x3 y3"
  shows "Frel R1 R2 R3 x y = Frel R1' R2' R3' x y"
  by (rule iffI;
    rule Frel_mono_strong,
    assumption;
    rule iffD1[OF assms(1)] iffD1[OF assms(2)] iffD1[OF assms(3)]
      iffD2[OF assms(1)] iffD2[OF assms(2)] iffD2[OF assms(3)];
    assumption)

lemma Frel_rel_inv_eq_rel_inv_Frel: "Frel R1\<inverse> R2\<inverse> R3\<inverse> = (Frel R1 R2 R3)\<inverse>"
  by (intro ext iffI;
    unfold rel_inv_iff_rel,
    erule FrelE,
    hypsubst,
    rule FrelI[where ?z="Fmap prod.swap prod.swap prod.swap _"];
      ((subst Fset_Fmap_eqs,
      rule image_subsetI,
      drule rev_subsetD,
      assumption,
      elim CollectE case_prodE,
      hypsubst,
      subst swap_simp,
      subst pair_mem_Collect_case_prod_iff,
      assumption) |
      (subst Fmap_comp_eq_Fmap_Fmap[symmetric],
        rule Fmap_cong;
        unfold comp_eq fst_swap snd_swap,
        rule refl)))

text \<open>Given the former axioms, the following axiom - subdistributivity of the
relator - is equivalent to the (F, Fmap) functor preserving weak pullbacks.\<close>

axiomatization
  where Frel_comp_le_Frel_rel_comp: "\<And>R1 R2 R3 S1 S2 S3.
    Frel R1 R2 R3 \<circ>\<circ> Frel S1 S2 S3 \<le> Frel (R1 \<circ>\<circ> S1) (R2 \<circ>\<circ> S2) (R3 \<circ>\<circ> S3)"

lemma fst_sndOp_eq_snd_fstOp: "fst \<circ> BNF_Def.sndOp P Q = snd \<circ> BNF_Def.fstOp P Q"
  unfolding fstOp_def sndOp_def by (intro ext) simp

lemma Frel_rel_comp_le_Frel_comp:
  "Frel (R1 \<circ>\<circ> S1) (R2 \<circ>\<circ> S2) (R3 \<circ>\<circ> S3) \<le> (Frel R1 R2 R3 \<circ>\<circ> Frel S1 S2 S3)"
  apply (rule le_relI)
  apply (erule FrelE)
  apply (rule rel_compI[where ?y="Fmap (snd \<circ> BNF_Def.fstOp R1 S1)
    (snd \<circ> BNF_Def.fstOp R2 S2) (snd \<circ> BNF_Def.fstOp R3 S3) _"])
  apply (rule FrelI[where ?z="Fmap (BNF_Def.fstOp R1 S1)
    (BNF_Def.fstOp R2 S2) (BNF_Def.fstOp R3 S3) _"])
    apply (subst Fset_Fmap_eqs,
      intro image_subsetI,
      rule fstOp_in[unfolded relcompp_eq_rel_comp],
      drule rev_subsetD,
      assumption+)+
    apply (subst Fmap_comp_eq_Fmap_Fmap[symmetric])
    apply (fold ext[of fst "fst \<circ> _", OF fst_fstOp[unfolded Fun_comp_eq_comp]])
    apply hypsubst
    apply (rule refl)
    apply (subst Fmap_comp_eq_Fmap_Fmap[symmetric])
    apply (rule refl)
    apply (rule FrelI[where ?z="Fmap (BNF_Def.sndOp R1 S1)
      (BNF_Def.sndOp R2 S2) (BNF_Def.sndOp R3 S3) _"])
    apply (subst Fset_Fmap_eqs,
      intro image_subsetI,
      rule sndOp_in[unfolded relcompp_eq_rel_comp],
      drule rev_subsetD,
      assumption+)+
    apply (subst Fmap_comp_eq_Fmap_Fmap[symmetric])
    apply (unfold fst_sndOp_eq_snd_fstOp)
    apply (rule refl)
    apply (subst Fmap_comp_eq_Fmap_Fmap[symmetric])
    apply (fold ext[of snd "snd \<circ> _", OF snd_sndOp[unfolded Fun_comp_eq_comp]])
    apply hypsubst
    apply (rule refl)
  done

corollary Frel_comp_eq_Frel_rel_comp:
  "Frel R1 R2 R3 \<circ>\<circ> Frel S1 S2 S3 = Frel (R1 \<circ>\<circ> S1) (R2 \<circ>\<circ> S2) (R3 \<circ>\<circ> S3)"
  by (rule antisym; rule Frel_comp_le_Frel_rel_comp Frel_rel_comp_le_Frel_comp)

lemma Frel_Fmap_eq1: "Frel R1 R2 R3 (Fmap f1 f2 f3 x) y =
  Frel (\<lambda>x. R1 (f1 x)) (\<lambda>x. R2 (f2 x)) (\<lambda>x. R3 (f3 x)) x y"
  apply (rule iffI)
    apply (fold comp_eq[of R1] comp_eq[of R2] comp_eq[of R3])
    apply (drule rel_compI[where ?R="Frel _ _ _" and ?S="Frel _ _ _",
      OF Frel_Grp_UNIV_Fmap])
    apply (unfold Grp_UNIV_eq_eq_comp)
    apply (drule le_relD[OF Frel_comp_le_Frel_rel_comp])
    apply (unfold eq_comp_rel_comp_eq_comp)
    apply assumption
    apply (fold eq_comp_rel_comp_eq_comp[where ?R=R1]
      eq_comp_rel_comp_eq_comp[where ?R=R2]
      eq_comp_rel_comp_eq_comp[where ?R=R3]
      Grp_UNIV_eq_eq_comp)
    apply (drule le_relD[OF Frel_rel_comp_le_Frel_comp])
    apply (erule rel_compE)
    apply (subst (asm) Frel_Grp_UNIV_iff_eq_Fmap)
    apply hypsubst
    apply assumption
  done

lemma Frel_Fmap_eq2: "Frel R1 R2 R3 x (Fmap g1 g2 g3 y) =
  Frel (\<lambda>x y. R1 x (g1 y)) (\<lambda>x y. R2 x (g2 y)) (\<lambda>x y. R3 x (g3 y)) x y"
  apply (subst rel_inv_iff_rel[of "Frel _ _ _", symmetric])
  apply (subst Frel_rel_inv_eq_rel_inv_Frel[symmetric])
  apply (subst Frel_Fmap_eq1)
  apply (rule sym)
  apply (subst rel_inv_iff_rel[of "Frel _ _ _", symmetric])
  apply (subst Frel_rel_inv_eq_rel_inv_Frel[symmetric])
  apply (unfold rel_inv_iff_rel)
  apply (rule refl)
  done

lemmas Frel_Fmap_eqs = Frel_Fmap_eq1 Frel_Fmap_eq2

paragraph \<open>Predicator\<close>

definition Fpred :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> bool) \<Rightarrow>
  ('d, 'a, 'b, 'c) F \<Rightarrow> bool"
  where "Fpred P1 P2 P3 x \<equiv> Frel ((=)\<restriction>\<^bsub>P1\<^esub>) ((=)\<restriction>\<^bsub>P2\<^esub>) ((=)\<restriction>\<^bsub>P3\<^esub>) x x"

lemma Fpred_mono_strong:
  assumes "Fpred P1 P2 P3 x"
  and "\<And>x1. x1 \<in> Fset1 x \<Longrightarrow> P1 x1 \<Longrightarrow> Q1 x1"
  and "\<And>x2. x2 \<in> Fset2 x \<Longrightarrow> P2 x2 \<Longrightarrow> Q2 x2"
  and "\<And>x3. x3 \<in> Fset3 x \<Longrightarrow> P3 x3 \<Longrightarrow> Q3 x3"
  shows "Fpred Q1 Q2 Q3 x"
  apply (insert assms(1))
  apply (unfold Fpred_def)
  apply (rule Frel_mono_strong,
    assumption;
    erule restrict_leftE,
    rule restrict_leftI,
    assumption,
    rule assms,
    assumption+)
  done

lemma Fpred_top: "Fpred \<top> \<top> \<top> x"
  apply (subst Fpred_def)
  apply (rule Frel_refl_strong;
    subst restrict_left_top_eq,
    rule refl)
  done

lemma FpredI:
  assumes "\<And>x1. x1 \<in> Fset1 x \<Longrightarrow> P1 x1"
  and "\<And>x2. x2 \<in> Fset2 x \<Longrightarrow> P2 x2"
  and "\<And>x3. x3 \<in> Fset3 x \<Longrightarrow> P3 x3"
  shows "Fpred P1 P2 P3 x"
  using assms by (rule Fpred_mono_strong[OF Fpred_top])

lemma FpredE:
  assumes "Fpred P1 P2 P3 x"
  obtains "\<And>x1. x1 \<in> Fset1 x \<Longrightarrow> P1 x1"
    "\<And>x2. x2 \<in> Fset2 x \<Longrightarrow> P2 x2"
    "\<And>x3. x3 \<in> Fset3 x \<Longrightarrow> P3 x3"
  by (elim meta_impE; (assumption |
    insert assms,
    subst (asm) Fpred_def,
    erule FrelE,
    hypsubst,
    subst (asm) Fset_Fmap_eqs,
    subst (asm) Domain_fst[symmetric],
    drule rev_subsetD,
    rule Domain_mono,
    assumption,
    unfold Domain_Collect_case_prod_eq_Collect_in_dom in_dom_restrict_left_eq,
    elim CollectE inf1E,
    assumption))

lemma Fpred_eq_ball: "Fpred P1 P2 P3 =
  (\<lambda>x. Ball (Fset1 x) P1 \<and> Ball (Fset2 x) P2 \<and> Ball (Fset3 x) P3)"
  by (intro ext iffI conjI ballI FpredI; elim FpredE conjE bspec)

lemma Fpred_Fmap_eq:
  "Fpred P1 P2 P3 (Fmap f1 f2 f3 x) = Fpred (P1 \<circ> f1) (P2 \<circ> f2) (P3 \<circ> f3) x"
  by (unfold Fpred_def Frel_Fmap_eqs)
  (rule iffI;
    erule FrelE,
    hypsubst,
    unfold Frel_Fmap_eqs,
    rule Frel_refl_strong;
    rule restrict_leftI,
    rule refl,
    drule rev_subsetD,
    assumption,
    elim CollectE case_prodE restrict_leftE,
    hypsubst,
    unfold comp_eq fst_conv,
    assumption)

lemma Fpred_in_dom_if_in_dom_Frel:
  assumes "in_dom (Frel R1 R2 R3) x"
  shows "Fpred (in_dom R1) (in_dom R2) (in_dom R3) x"
  apply (insert assms)
  apply (elim in_domE FrelE)
  apply hypsubst
  apply (subst Fpred_Fmap_eq)
  apply (rule FpredI;
    drule rev_subsetD,
    assumption,
    elim CollectE case_prodE,
    hypsubst,
    unfold comp_eq fst_conv,
    rule in_domI,
    assumption)
  done

lemma in_dom_Frel_if_Fpred_in_dom:
  assumes "Fpred (in_dom R1) (in_dom R2) (in_dom R3) x"
  shows "in_dom (Frel R1 R2 R3) x"
  apply (insert assms)
  apply (subst (asm) Fpred_eq_ball)
  apply (elim conjE)
  apply (subst (asm) ball_in_dom_iff_ball_ex,
    drule bchoice, \<comment>\<open>requires the axiom of choice.\<close>
    erule exE)+
  apply (rule in_domI[where ?x=x and ?y="Fmap _ _ _ x" for x])
  apply (subst Frel_Fmap_eq2)
  apply (rule Frel_refl_strong)
  apply (drule bspec[of "Fset1 _"])
  apply assumption+
  apply (drule bspec[of "Fset2 _"])
  apply assumption+
  apply (drule bspec[of "Fset3 _"])
  apply assumption+
  done

lemma in_dom_Frel_eq_Fpred_in_dom:
  "in_dom (Frel R1 R2 R3) = Fpred (in_dom R1) (in_dom R2) (in_dom R3)"
  by (intro ext iffI; rule Fpred_in_dom_if_in_dom_Frel in_dom_Frel_if_Fpred_in_dom)

lemma in_codom_Frel_eq_Fpred_in_codom:
  "in_codom (Frel R1 R2 R3) = Fpred (in_codom R1) (in_codom R2) (in_codom R3)"
  apply (subst in_dom_rel_inv_eq_in_codom[symmetric])
  apply (subst Frel_rel_inv_eq_rel_inv_Frel[symmetric])
  apply (subst in_dom_Frel_eq_Fpred_in_dom)
  apply (subst in_dom_rel_inv_eq_in_codom)+
  apply (rule refl)
  done

lemma in_field_Frel_eq_Fpred_in_in_field:
  "in_field (Frel R1 R2 R3) =
    Fpred (in_dom R1) (in_dom R2) (in_dom R3) \<squnion>
    Fpred (in_codom R1) (in_codom R2) (in_codom R3)"
  apply (subst in_field_eq_in_dom_sup_in_codom)
  apply (subst in_dom_Frel_eq_Fpred_in_dom)
  apply (subst in_codom_Frel_eq_Fpred_in_codom)
  apply (rule refl)
  done

lemma Frel_restrict_left_Fpred_eq_Frel_restrict_left:
  fixes R1 :: "'a1 \<Rightarrow> 'a2 \<Rightarrow> bool"
  and R2 :: "'b1 \<Rightarrow> 'b2 \<Rightarrow> bool"
  and R3 :: "'c1 \<Rightarrow> 'c2 \<Rightarrow> bool"
  and P1 :: "'a1 \<Rightarrow> bool"
  and P2 :: "'b1 \<Rightarrow> bool"
  and P3 :: "'c1 \<Rightarrow> bool"
  shows "(Frel R1 R2 R3 :: ('d, 'a1, 'b1, 'c1) F \<Rightarrow> _)\<restriction>\<^bsub>Fpred P1 P2 P3 :: ('d, 'a1, 'b1, 'c1) F \<Rightarrow> _\<^esub> =
    Frel (R1\<restriction>\<^bsub>P1\<^esub>) (R2\<restriction>\<^bsub>P2\<^esub>) (R3\<restriction>\<^bsub>P3\<^esub>)"
  apply (intro ext)
  apply (rule iffI)
    apply (erule restrict_leftE)
    apply (elim FpredE)
    apply (rule Frel_mono_strong,
      assumption;
      rule restrict_leftI,
      assumption+)
    apply (rule restrict_leftI)
      apply (rule Frel_mono_strong,
        assumption;
        erule restrict_leftE,
        assumption)
      apply (drule in_domI[of "Frel (R1\<restriction>\<^bsub>P1\<^esub>) (R2\<restriction>\<^bsub>P2\<^esub>) (R3\<restriction>\<^bsub>P3\<^esub>)"])
      apply (drule Fpred_in_dom_if_in_dom_Frel)
      apply (rule Fpred_mono_strong,
        assumption;
        unfold in_dom_restrict_left_eq inf_apply inf_bool_def;
        rule conjunct2,
        assumption)
  done

lemma Frel_restrict_right_Fpred_eq_Frel_restrict_right:
  fixes R1 :: "'a1 \<Rightarrow> 'a2 \<Rightarrow> bool"
  and R2 :: "'b1 \<Rightarrow> 'b2 \<Rightarrow> bool"
  and R3 :: "'c1 \<Rightarrow> 'c2 \<Rightarrow> bool"
  and P1 :: "'a2 \<Rightarrow> bool"
  and P2 :: "'b2 \<Rightarrow> bool"
  and P3 :: "'c2 \<Rightarrow> bool"
  shows "(Frel R1 R2 R3 :: _ \<Rightarrow> ('d, 'a2, 'b2, 'c2) F \<Rightarrow> _)\<upharpoonleft>\<^bsub>Fpred P1 P2 P3 :: ('d, 'a2, 'b2, 'c2) F \<Rightarrow> _\<^esub> =
    Frel (R1\<upharpoonleft>\<^bsub>P1\<^esub>) (R2\<upharpoonleft>\<^bsub>P2\<^esub>) (R3\<upharpoonleft>\<^bsub>P3\<^esub>)"
  apply (subst restrict_right_eq)
  apply (subst Frel_rel_inv_eq_rel_inv_Frel[symmetric])
  apply (subst Frel_restrict_left_Fpred_eq_Frel_restrict_left)
  apply (subst Frel_rel_inv_eq_rel_inv_Frel[symmetric])
  apply (fold restrict_right_eq)
  apply (rule refl)
  done

locale transport_natural_functor =
  t1 : transport L1 R1 l1 r1 + t2 : transport L2 R2 l2 r2 +
  t3 : transport L3 R3 l3 r3
  for L1 :: "'a1 \<Rightarrow> 'a1 \<Rightarrow> bool"
  and R1 :: "'b1 \<Rightarrow> 'b1 \<Rightarrow> bool"
  and l1 :: "'a1 \<Rightarrow> 'b1"
  and r1 :: "'b1 \<Rightarrow> 'a1"
  and L2 :: "'a2 \<Rightarrow> 'a2 \<Rightarrow> bool"
  and R2 :: "'b2 \<Rightarrow> 'b2 \<Rightarrow> bool"
  and l2 :: "'a2 \<Rightarrow> 'b2"
  and r2 :: "'b2 \<Rightarrow> 'a2"
  and L3 :: "'a3 \<Rightarrow> 'a3 \<Rightarrow> bool"
  and R3 :: "'b3 \<Rightarrow> 'b3 \<Rightarrow> bool"
  and l3 :: "'a3 \<Rightarrow> 'b3"
  and r3 :: "'b3 \<Rightarrow> 'a3"
begin

notation L1 (infix "\<le>\<^bsub>L1\<^esub>" 50)
notation R1 (infix "\<le>\<^bsub>R1\<^esub>" 50)
notation L2 (infix "\<le>\<^bsub>L2\<^esub>" 50)
notation R2 (infix "\<le>\<^bsub>R2\<^esub>" 50)
notation L3 (infix "\<le>\<^bsub>L3\<^esub>" 50)
notation R3 (infix "\<le>\<^bsub>R3\<^esub>" 50)

notation t1.ge_left (infix "\<ge>\<^bsub>L1\<^esub>" 50)
notation t1.ge_right (infix "\<ge>\<^bsub>R1\<^esub>" 50)
notation t2.ge_left (infix "\<ge>\<^bsub>L2\<^esub>" 50)
notation t2.ge_right (infix "\<ge>\<^bsub>R2\<^esub>" 50)
notation t3.ge_left (infix "\<ge>\<^bsub>L3\<^esub>" 50)
notation t3.ge_right (infix "\<ge>\<^bsub>R3\<^esub>" 50)

notation t1.Galois (infix "\<^bsub>L1\<^esub>\<lessapprox>" 50)
notation t1.flip_Galois (infix "\<^bsub>R1\<^esub>\<lessapprox>" 50)
notation t2.Galois (infix "\<^bsub>L2\<^esub>\<lessapprox>" 50)
notation t2.flip_Galois (infix "\<^bsub>R2\<^esub>\<lessapprox>" 50)
notation t3.Galois (infix "\<^bsub>L3\<^esub>\<lessapprox>" 50)
notation t3.flip_Galois (infix "\<^bsub>R3\<^esub>\<lessapprox>" 50)

notation t1.ge_Galois (infix "\<greaterapprox>\<^bsub>L1\<^esub>" 50)
notation t1.flip_ge_Galois (infix "\<greaterapprox>\<^bsub>R1\<^esub>" 50)
notation t2.ge_Galois (infix "\<greaterapprox>\<^bsub>L2\<^esub>" 50)
notation t2.flip_ge_Galois (infix "\<greaterapprox>\<^bsub>R2\<^esub>" 50)
notation t3.ge_Galois (infix "\<greaterapprox>\<^bsub>L3\<^esub>" 50)
notation t3.flip_ge_Galois (infix "\<greaterapprox>\<^bsub>R3\<^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 t2.flip_inv_Galois (infix "\<^bsub>R2\<^esub>\<greaterapprox>" 50)
notation t2.flip_inv_ge_Galois (infix "\<lessapprox>\<^bsub>R2\<^esub>" 50)
notation t3.flip_inv_Galois (infix "\<^bsub>R3\<^esub>\<greaterapprox>" 50)
notation t3.flip_inv_ge_Galois (infix "\<lessapprox>\<^bsub>R3\<^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 t2.flip_flip_inv_Galois (infix "\<^bsub>L2\<^esub>\<greaterapprox>" 50)
notation t2.flip_flip_inv_ge_Galois (infix "\<lessapprox>\<^bsub>L2\<^esub>" 50)
notation t3.flip_flip_inv_Galois (infix "\<^bsub>L3\<^esub>\<greaterapprox>" 50)
notation t3.flip_flip_inv_ge_Galois (infix "\<lessapprox>\<^bsub>L3\<^esub>" 50)

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

definition "L \<equiv> Frel (\<le>\<^bsub>L1\<^esub>) (\<le>\<^bsub>L2\<^esub>) (\<le>\<^bsub>L3\<^esub>)"

lemma left_rel_eq_Frel: "L = Frel (\<le>\<^bsub>L1\<^esub>) (\<le>\<^bsub>L2\<^esub>) (\<le>\<^bsub>L3\<^esub>)"
  unfolding L_def ..

definition "l \<equiv> Fmap l1 l2 l3"

lemma left_eq_Fmap: "l = Fmap l1 l2 l3"
  unfolding l_def ..

context
begin

interpretation flip :
  transport_natural_functor R1 L1 r1 l1 R2 L2 r2 l2 R3 L3 r3 l3 .

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

lemma right_rel_eq_Frel: "R = Frel (\<le>\<^bsub>R1\<^esub>) (\<le>\<^bsub>R2\<^esub>) (\<le>\<^bsub>R3\<^esub>)"
  unfolding flip.left_rel_eq_Frel ..

lemma right_eq_Fmap: "r = Fmap r1 r2 r3"
  unfolding flip.left_eq_Fmap ..

lemmas transport_defs = left_rel_eq_Frel left_eq_Fmap
  right_rel_eq_Frel right_eq_Fmap

end

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 unit_eq_Fmap: "\<eta> = Fmap \<eta>\<^sub>1 \<eta>\<^sub>2 \<eta>\<^sub>3"
  unfolding unit_eq_comp by (simp only: right_eq_Fmap left_eq_Fmap
    flip: Fmap_comp t1.unit_eq_comp t2.unit_eq_comp t3.unit_eq_comp)

interpretation flip_inv : transport_natural_functor "(\<ge>\<^bsub>R1\<^esub>)" "(\<ge>\<^bsub>L1\<^esub>)" r1 l1
  "(\<ge>\<^bsub>R2\<^esub>)" "(\<ge>\<^bsub>L2\<^esub>)" r2 l2 "(\<ge>\<^bsub>R3\<^esub>)" "(\<ge>\<^bsub>L3\<^esub>)" r3 l3
  rewrites "flip_inv.unit \<equiv> \<epsilon>" and "flip_inv.t1.unit \<equiv> \<epsilon>\<^sub>1"
  and "flip_inv.t2.unit \<equiv> \<epsilon>\<^sub>2" and "flip_inv.t3.unit \<equiv> \<epsilon>\<^sub>3"
  by (simp_all only: order_functors.flip_counit_eq_unit)

lemma counit_eq_Fmap: "\<epsilon> = Fmap \<epsilon>\<^sub>1 \<epsilon>\<^sub>2 \<epsilon>\<^sub>3"
  by (fact flip_inv.unit_eq_Fmap)

lemma flip_inv_right_eq_ge_left: "flip_inv.R = (\<ge>\<^bsub>L\<^esub>)"
  unfolding left_rel_eq_Frel flip_inv.right_rel_eq_Frel
  by (fact Frel_rel_inv_eq_rel_inv_Frel)

interpretation flip :
  transport_natural_functor R1 L1 r1 l1 R2 L2 r2 l2 R3 L3 r3 l3 .

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

lemma mono_wrt_rel_leftI:
  assumes "((\<le>\<^bsub>L1\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R1\<^esub>)) l1"
  and "((\<le>\<^bsub>L2\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R2\<^esub>)) l2"
  and "((\<le>\<^bsub>L3\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R3\<^esub>)) l3"
  shows "((\<le>\<^bsub>L\<^esub>) \<Rrightarrow>\<^sub>m (\<le>\<^bsub>R\<^esub>)) l"
  apply (unfold left_rel_eq_Frel right_rel_eq_Frel left_eq_Fmap)
  apply (rule dep_mono_wrt_relI)
  apply (unfold Frel_Fmap_eqs)
  apply (fold rel_map_eq)
  apply (rule le_relD[OF Frel_mono])
    apply (subst mono_wrt_rel_iff_le_rel_map[symmetric], rule assms)+
    apply assumption
  done

end

end


(******************************************************************************)
(* External Algorithm for Calculating the Transitive Closure in Isabelle/HOL  *)
(* Author: Frank Zeyda, University of York (UK)                               *)
(* Email: frank.zeyda@york.ac.uk                                              *)
(******************************************************************************)

section {* Transcl Tests *}

theory transcl_tests
imports transcl
begin

(* Tool Invocation Test *)

ML \<open>
  val input = "{(A, B), (B, C), (A, D), (B, E)}";
  val result = Transcl.transcl_run @{context} input "";
  val Transcl.Data data = result;
  val (ginit, gfini) = Transcl.parse_rel_data data;
\<close>

(* Reconstruction Tests *)

ML \<open>
  val term = @{term "{(A, B), (B, C), (A, D), (B, E)}"};
  val r1  = Transcl.transcl1 @{context} term;
  val r2 = Transcl.transcl2 @{context} @{term "{(A, B), (B, C)}"};
  val r3 = Transcl.transcl2 @{context} @{term "{(1, 2), (2, 3)}"};
\<close>

ML \<open>
  val _ = Output.writeln (Syntax.string_of_term @{context} term);
  val _ = Output.writeln (Syntax.string_of_term @{context} r1);
  val _ = Output.writeln (Syntax.string_of_term @{context} r2);
  (* Does not give the expected result as the relation is non-homogeneous. *)
  val _ = Output.writeln (Syntax.string_of_term @{context} r3);
\<close>

definition myrel1:
"myrel1 = {(''A'', ''B''), (''B'', ''C''), (''A'', ''D''), (''B'', ''E'')}"

definition myrel2:
"myrel2 = {(''D'', ''A'')}"

definition myrel3:
"myrel3 = {(1, 2), (2, 3), (1, 4), (2, 5)}"

(* PreSimplifier Tests *)

ML \<open>
  val _ = Output.writeln
    (Syntax.string_of_term @{context}
      (PreSimplifier.presimplify @{context}
        Transcl_Rewriter.is_rel_const @{term "myrel1 \<union> myrel2"}));

  val _ = Output.writeln
    (Syntax.string_of_term @{context}
      (PreSimplifier.presimplify @{context}
        Transcl_Rewriter.is_rel_const @{term "myrel3"}));
\<close>

value "myrel1 \<union> myrel2"

value "myrel3" -- {* In contrast, this does not give us quite what we want! *}

(* Miscellaneous Experiments *)

find_theorems name:"Set." name:"insert"

lemma "TRUE (myrel1 \<union> myrel2)"
apply (unfold myrel1 myrel2)
apply (simp only: Set.Un_insert_left Set.Un_empty_left)
oops

hide_const myrel1 myrel2 myrel3
end


theory "EvalHeap"
  imports "AList-Utils" Env Nominal2.Nominal2 "HOLCF-Utils"
begin

subsubsection \<open>Conversion from heaps to environments\<close>

fun
  evalHeap :: "('var \<times> 'exp) list \<Rightarrow> ('exp \<Rightarrow> 'value::{pure,pcpo}) \<Rightarrow> 'var \<Rightarrow> 'value"
where
  "evalHeap [] _ = \<bottom>"
| "evalHeap ((x,e)#h) eval = (evalHeap h eval) (x := eval e)"

lemma cont2cont_evalHeap[simp, cont2cont]:
  "(\<And> e . e \<in> snd ` set h \<Longrightarrow> cont (\<lambda>\<rho>. eval \<rho> e)) \<Longrightarrow> cont (\<lambda> \<rho>. evalHeap h (eval \<rho>))"
  by(induct h, auto)

lemma evalHeap_eqvt[eqvt]:
  "\<pi> \<bullet> evalHeap h eval = evalHeap (\<pi> \<bullet> h) (\<pi> \<bullet> eval)"
  by (induct h) (auto simp add:fun_upd_eqvt  simp del: fun_upd_apply)

lemma edom_evalHeap_subset:"edom (evalHeap h eval) \<subseteq> domA h"
  by (induct h eval rule:evalHeap.induct) (auto dest:subsetD[OF edom_fun_upd_subset] simp del: fun_upd_apply)

lemma evalHeap_cong[fundef_cong]:
  "\<lbrakk> heap1 = heap2 ;  (\<And> e. e \<in> snd ` set heap2 \<Longrightarrow> eval1 e = eval2 e) \<rbrakk>
    \<Longrightarrow>  evalHeap heap1 eval1 = evalHeap heap2 eval2"
 by (induct heap2 eval2 arbitrary:heap1 rule:evalHeap.induct, auto)

lemma lookupEvalHeap:
  assumes "v \<in> domA h"
  shows "(evalHeap h f) v = f (the (map_of h v))"
  using assms
  by (induct h f rule: evalHeap.induct) auto

lemma lookupEvalHeap':
  assumes "map_of \<Gamma> v = Some e"
  shows "(evalHeap \<Gamma> f) v = f e"
  using assms
  by (induct \<Gamma> f rule: evalHeap.induct) auto

lemma lookupEvalHeap_other[simp]:
  assumes "v \<notin> domA \<Gamma>"
  shows "(evalHeap \<Gamma> f) v = \<bottom>"
  using assms
  by (induct \<Gamma> f rule: evalHeap.induct) auto

lemma env_restr_evalHeap_noop:
  "domA h \<subseteq> S \<Longrightarrow> env_restr S (evalHeap h eval) = evalHeap h eval"
  apply (rule ext)
  apply (case_tac "x \<in> S")
  apply (auto simp add: lookupEvalHeap intro: lookupEvalHeap_other)
  done

lemma env_restr_evalHeap_same[simp]:
  "env_restr (domA h) (evalHeap h eval) = evalHeap h eval"
  by (simp add: env_restr_evalHeap_noop)

lemma evalHeap_cong':
  "\<lbrakk> (\<And> x. x \<in> domA heap \<Longrightarrow> eval1 (the (map_of heap x)) = eval2 (the (map_of heap x))) \<rbrakk>
    \<Longrightarrow>  evalHeap heap eval1 = evalHeap heap eval2"
 apply (rule ext)
 apply (case_tac "x \<in> domA heap")
 apply (auto simp add: lookupEvalHeap)
 done

lemma lookupEvalHeapNotAppend[simp]:
  assumes "x \<notin> domA \<Gamma>"
  shows "(evalHeap (\<Gamma>@h) f) x = evalHeap h f x"
  using assms by (induct \<Gamma>, auto)

lemma evalHeap_delete[simp]: "evalHeap (delete x \<Gamma>) eval = env_delete x (evalHeap \<Gamma> eval)"
  by (induct \<Gamma>) auto

lemma evalHeap_mono:
  "x \<notin> domA \<Gamma> \<Longrightarrow>
  evalHeap \<Gamma> eval \<sqsubseteq> evalHeap ((x, e) # \<Gamma>) eval"
   apply simp
   apply (rule fun_belowI)
   apply (case_tac "xa \<in> domA \<Gamma>")
   apply (case_tac "xa = x")
   apply auto
   done

subsubsection \<open>Reordering lemmas\<close>

lemma evalHeap_reorder:
  assumes "map_of \<Gamma> = map_of \<Delta>"
  shows "evalHeap \<Gamma> h = evalHeap \<Delta> h"
proof (rule ext)
  from assms
  have *: "domA \<Gamma> = domA \<Delta>" by (metis dom_map_of_conv_domA)

  fix x
  show "evalHeap \<Gamma> h x = evalHeap \<Delta> h x"
    using assms(1) *
    apply (cases "x \<in> domA \<Gamma>")
    apply (auto simp add: lookupEvalHeap)
    done
qed

lemma evalHeap_reorder_head:
  assumes "x \<noteq> y"
  shows "evalHeap ((x,e1)#(y,e2)#\<Gamma>) eval = evalHeap ((y,e2)#(x,e1)#\<Gamma>) eval"
  by (rule evalHeap_reorder) (simp add: fun_upd_twist[OF assms])

lemma evalHeap_reorder_head_append:
  assumes "x \<notin> domA \<Gamma>"
  shows "evalHeap ((x,e)#\<Gamma>@\<Delta>) eval = evalHeap (\<Gamma> @ ((x,e)#\<Delta>)) eval"
  by (rule evalHeap_reorder) (simp, metis assms dom_map_of_conv_domA map_add_upd_left)

lemma evalHeap_subst_exp:
  assumes "eval e = eval e'"
  shows "evalHeap ((x,e)#\<Gamma>) eval = evalHeap ((x,e')#\<Gamma>) eval"
  by (simp add: assms)

end


(*  Title:      Sequents/LK0.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1993  University of Cambridge

There may be printing problems if a seqent is in expanded normal form
(eta-expanded, beta-contracted).
*)

section \<open>Classical First-Order Sequent Calculus\<close>

theory LK0
imports Sequents
begin

setup \<open>Proofterm.set_preproc (Proof_Rewrite_Rules.standard_preproc [])\<close>

class "term"
default_sort "term"

consts

  Trueprop       :: "two_seqi"

  True         :: o
  False        :: o
  equal        :: "['a,'a] \<Rightarrow> o"     (infixl "=" 50)
  Not          :: "o \<Rightarrow> o"           ("\<not> _" [40] 40)
  conj         :: "[o,o] \<Rightarrow> o"       (infixr "\<and>" 35)
  disj         :: "[o,o] \<Rightarrow> o"       (infixr "\<or>" 30)
  imp          :: "[o,o] \<Rightarrow> o"       (infixr "\<longrightarrow>" 25)
  iff          :: "[o,o] \<Rightarrow> o"       (infixr "\<longleftrightarrow>" 25)
  The          :: "('a \<Rightarrow> o) \<Rightarrow> 'a"  (binder "THE " 10)
  All          :: "('a \<Rightarrow> o) \<Rightarrow> o"   (binder "\<forall>" 10)
  Ex           :: "('a \<Rightarrow> o) \<Rightarrow> o"   (binder "\<exists>" 10)

syntax
 "_Trueprop"    :: "two_seqe" ("((_)/ \<turnstile> (_))" [6,6] 5)

parse_translation \<open>[(\<^syntax_const>\<open>_Trueprop\<close>, K (two_seq_tr \<^const_syntax>\<open>Trueprop\<close>))]\<close>
print_translation \<open>[(\<^const_syntax>\<open>Trueprop\<close>, K (two_seq_tr' \<^syntax_const>\<open>_Trueprop\<close>))]\<close>

abbreviation
  not_equal  (infixl "\<noteq>" 50) where
  "x \<noteq> y \<equiv> \<not> (x = y)"

axiomatization where

  (*Structural rules: contraction, thinning, exchange [Soren Heilmann] *)

  contRS: "$H \<turnstile> $E, $S, $S, $F \<Longrightarrow> $H \<turnstile> $E, $S, $F" and
  contLS: "$H, $S, $S, $G \<turnstile> $E \<Longrightarrow> $H, $S, $G \<turnstile> $E" and

  thinRS: "$H \<turnstile> $E, $F \<Longrightarrow> $H \<turnstile> $E, $S, $F" and
  thinLS: "$H, $G \<turnstile> $E \<Longrightarrow> $H, $S, $G \<turnstile> $E" and

  exchRS: "$H \<turnstile> $E, $R, $S, $F \<Longrightarrow> $H \<turnstile> $E, $S, $R, $F" and
  exchLS: "$H, $R, $S, $G \<turnstile> $E \<Longrightarrow> $H, $S, $R, $G \<turnstile> $E" and

  cut:   "\<lbrakk>$H \<turnstile> $E, P;  $H, P \<turnstile> $E\<rbrakk> \<Longrightarrow> $H \<turnstile> $E" and

  (*Propositional rules*)

  basic: "$H, P, $G \<turnstile> $E, P, $F" and

  conjR: "\<lbrakk>$H\<turnstile> $E, P, $F;  $H\<turnstile> $E, Q, $F\<rbrakk> \<Longrightarrow> $H\<turnstile> $E, P \<and> Q, $F" and
  conjL: "$H, P, Q, $G \<turnstile> $E \<Longrightarrow> $H, P \<and> Q, $G \<turnstile> $E" and

  disjR: "$H \<turnstile> $E, P, Q, $F \<Longrightarrow> $H \<turnstile> $E, P \<or> Q, $F" and
  disjL: "\<lbrakk>$H, P, $G \<turnstile> $E;  $H, Q, $G \<turnstile> $E\<rbrakk> \<Longrightarrow> $H, P \<or> Q, $G \<turnstile> $E" and

  impR:  "$H, P \<turnstile> $E, Q, $F \<Longrightarrow> $H \<turnstile> $E, P \<longrightarrow> Q, $F" and
  impL:  "\<lbrakk>$H,$G \<turnstile> $E,P;  $H, Q, $G \<turnstile> $E\<rbrakk> \<Longrightarrow> $H, P \<longrightarrow> Q, $G \<turnstile> $E" and

  notR:  "$H, P \<turnstile> $E, $F \<Longrightarrow> $H \<turnstile> $E, \<not> P, $F" and
  notL:  "$H, $G \<turnstile> $E, P \<Longrightarrow> $H, \<not> P, $G \<turnstile> $E" and

  FalseL: "$H, False, $G \<turnstile> $E" and

  True_def: "True \<equiv> False \<longrightarrow> False" and
  iff_def:  "P \<longleftrightarrow> Q \<equiv> (P \<longrightarrow> Q) \<and> (Q \<longrightarrow> P)"

axiomatization where
  (*Quantifiers*)

  allR:  "(\<And>x. $H \<turnstile> $E, P(x), $F) \<Longrightarrow> $H \<turnstile> $E, \<forall>x. P(x), $F" and
  allL:  "$H, P(x), $G, \<forall>x. P(x) \<turnstile> $E \<Longrightarrow> $H, \<forall>x. P(x), $G \<turnstile> $E" and

  exR:   "$H \<turnstile> $E, P(x), $F, \<exists>x. P(x) \<Longrightarrow> $H \<turnstile> $E, \<exists>x. P(x), $F" and
  exL:   "(\<And>x. $H, P(x), $G \<turnstile> $E) \<Longrightarrow> $H, \<exists>x. P(x), $G \<turnstile> $E" and

  (*Equality*)
  refl:  "$H \<turnstile> $E, a = a, $F" and
  subst: "\<And>G H E. $H(a), $G(a) \<turnstile> $E(a) \<Longrightarrow> $H(b), a=b, $G(b) \<turnstile> $E(b)"

  (* Reflection *)

axiomatization where
  eq_reflection:  "\<turnstile> x = y \<Longrightarrow> (x \<equiv> y)" and
  iff_reflection: "\<turnstile> P \<longleftrightarrow> Q \<Longrightarrow> (P \<equiv> Q)"

  (*Descriptions*)

axiomatization where
  The: "\<lbrakk>$H \<turnstile> $E, P(a), $F;  \<And>x.$H, P(x) \<turnstile> $E, x=a, $F\<rbrakk> \<Longrightarrow>
         $H \<turnstile> $E, P(THE x. P(x)), $F"

definition If :: "[o, 'a, 'a] \<Rightarrow> 'a" ("(if (_)/ then (_)/ else (_))" 10)
  where "If(P,x,y) \<equiv> THE z::'a. (P \<longrightarrow> z = x) \<and> (\<not> P \<longrightarrow> z = y)"

(** Structural Rules on formulas **)

(*contraction*)

lemma contR: "$H \<turnstile> $E, P, P, $F \<Longrightarrow> $H \<turnstile> $E, P, $F"
  by (rule contRS)

lemma contL: "$H, P, P, $G \<turnstile> $E \<Longrightarrow> $H, P, $G \<turnstile> $E"
  by (rule contLS)

(*thinning*)

lemma thinR: "$H \<turnstile> $E, $F \<Longrightarrow> $H \<turnstile> $E, P, $F"
  by (rule thinRS)

lemma thinL: "$H, $G \<turnstile> $E \<Longrightarrow> $H, P, $G \<turnstile> $E"
  by (rule thinLS)

(*exchange*)

lemma exchR: "$H \<turnstile> $E, Q, P, $F \<Longrightarrow> $H \<turnstile> $E, P, Q, $F"
  by (rule exchRS)

lemma exchL: "$H, Q, P, $G \<turnstile> $E \<Longrightarrow> $H, P, Q, $G \<turnstile> $E"
  by (rule exchLS)

ML \<open>
(*Cut and thin, replacing the right-side formula*)
fun cutR_tac ctxt s i =
  Rule_Insts.res_inst_tac ctxt [((("P", 0), Position.none), s)] [] @{thm cut} i THEN
  resolve_tac ctxt @{thms thinR} i

(*Cut and thin, replacing the left-side formula*)
fun cutL_tac ctxt s i =
  Rule_Insts.res_inst_tac ctxt [((("P", 0), Position.none), s)] [] @{thm cut} i THEN
  resolve_tac ctxt @{thms thinL} (i + 1)
\<close>

(** If-and-only-if rules **)
lemma iffR: "\<lbrakk>$H,P \<turnstile> $E,Q,$F;  $H,Q \<turnstile> $E,P,$F\<rbrakk> \<Longrightarrow> $H \<turnstile> $E, P \<longleftrightarrow> Q, $F"
  apply (unfold iff_def)
  apply (assumption | rule conjR impR)+
  done

lemma iffL: "\<lbrakk>$H,$G \<turnstile> $E,P,Q;  $H,Q,P,$G \<turnstile> $E\<rbrakk> \<Longrightarrow> $H, P \<longleftrightarrow> Q, $G \<turnstile> $E"
  apply (unfold iff_def)
  apply (assumption | rule conjL impL basic)+
  done

lemma iff_refl: "$H \<turnstile> $E, (P \<longleftrightarrow> P), $F"
  apply (rule iffR basic)+
  done

lemma TrueR: "$H \<turnstile> $E, True, $F"
  apply (unfold True_def)
  apply (rule impR)
  apply (rule basic)
  done

(*Descriptions*)
lemma the_equality:
  assumes p1: "$H \<turnstile> $E, P(a), $F"
    and p2: "\<And>x. $H, P(x) \<turnstile> $E, x=a, $F"
  shows "$H \<turnstile> $E, (THE x. P(x)) = a, $F"
  apply (rule cut)
   apply (rule_tac [2] p2)
  apply (rule The, rule thinR, rule exchRS, rule p1)
  apply (rule thinR, rule exchRS, rule p2)
  done

(** Weakened quantifier rules.  Incomplete, they let the search terminate.**)

lemma allL_thin: "$H, P(x), $G \<turnstile> $E \<Longrightarrow> $H, \<forall>x. P(x), $G \<turnstile> $E"
  apply (rule allL)
  apply (erule thinL)
  done

lemma exR_thin: "$H \<turnstile> $E, P(x), $F \<Longrightarrow> $H \<turnstile> $E, \<exists>x. P(x), $F"
  apply (rule exR)
  apply (erule thinR)
  done

(*The rules of LK*)

lemmas [safe] =
  iffR iffL
  notR notL
  impR impL
  disjR disjL
  conjR conjL
  FalseL TrueR
  refl basic
ML \<open>val prop_pack = Cla.get_pack \<^context>\<close>

lemmas [safe] = exL allR
lemmas [unsafe] = the_equality exR_thin allL_thin
ML \<open>val LK_pack = Cla.get_pack \<^context>\<close>

ML \<open>
  val LK_dup_pack =
    Cla.put_pack prop_pack \<^context>
    |> fold_rev Cla.add_safe @{thms allR exL}
    |> fold_rev Cla.add_unsafe @{thms allL exR the_equality}
    |> Cla.get_pack;
\<close>

method_setup fast_prop =
  \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Cla.fast_tac (Cla.put_pack prop_pack ctxt)))\<close>

method_setup fast_dup =
  \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Cla.fast_tac (Cla.put_pack LK_dup_pack ctxt)))\<close>

method_setup best_dup =
  \<open>Scan.succeed (fn ctxt => SIMPLE_METHOD' (Cla.best_tac (Cla.put_pack LK_dup_pack ctxt)))\<close>

method_setup lem = \<open>
  Attrib.thm >> (fn th => fn ctxt =>
    SIMPLE_METHOD' (fn i =>
      resolve_tac ctxt [@{thm thinR} RS @{thm cut}] i THEN
      REPEAT (resolve_tac ctxt @{thms thinL} i) THEN
      resolve_tac ctxt [th] i))
\<close>

lemma mp_R:
  assumes major: "$H \<turnstile> $E, $F, P \<longrightarrow> Q"
    and minor: "$H \<turnstile> $E, $F, P"
  shows "$H \<turnstile> $E, Q, $F"
  apply (rule thinRS [THEN cut], rule major)
  apply step
  apply (rule thinR, rule minor)
  done

lemma mp_L:
  assumes major: "$H, $G \<turnstile> $E, P \<longrightarrow> Q"
    and minor: "$H, $G, Q \<turnstile> $E"
  shows "$H, P, $G \<turnstile> $E"
  apply (rule thinL [THEN cut], rule major)
  apply step
  apply (rule thinL, rule minor)
  done

(** Two rules to generate left- and right- rules from implications **)

lemma R_of_imp:
  assumes major: "\<turnstile> P \<longrightarrow> Q"
    and minor: "$H \<turnstile> $E, $F, P"
  shows "$H \<turnstile> $E, Q, $F"
  apply (rule mp_R)
   apply (rule_tac [2] minor)
  apply (rule thinRS, rule major [THEN thinLS])
  done

lemma L_of_imp:
  assumes major: "\<turnstile> P \<longrightarrow> Q"
    and minor: "$H, $G, Q \<turnstile> $E"
  shows "$H, P, $G \<turnstile> $E"
  apply (rule mp_L)
   apply (rule_tac [2] minor)
  apply (rule thinRS, rule major [THEN thinLS])
  done

(*Can be used to create implications in a subgoal*)
lemma backwards_impR:
  assumes prem: "$H, $G \<turnstile> $E, $F, P \<longrightarrow> Q"
  shows "$H, P, $G \<turnstile> $E, Q, $F"
  apply (rule mp_L)
   apply (rule_tac [2] basic)
  apply (rule thinR, rule prem)
  done

lemma conjunct1: "\<turnstile>P \<and> Q \<Longrightarrow> \<turnstile>P"
  apply (erule thinR [THEN cut])
  apply fast
  done

lemma conjunct2: "\<turnstile>P \<and> Q \<Longrightarrow> \<turnstile>Q"
  apply (erule thinR [THEN cut])
  apply fast
  done

lemma spec: "\<turnstile> (\<forall>x. P(x)) \<Longrightarrow> \<turnstile> P(x)"
  apply (erule thinR [THEN cut])
  apply fast
  done

(** Equality **)

lemma sym: "\<turnstile> a = b \<longrightarrow> b = a"
  by (safe add!: subst)

lemma trans: "\<turnstile> a = b \<longrightarrow> b = c \<longrightarrow> a = c"
  by (safe add!: subst)

(* Symmetry of equality in hypotheses *)
lemmas symL = sym [THEN L_of_imp]

(* Symmetry of equality in hypotheses *)
lemmas symR = sym [THEN R_of_imp]

lemma transR: "\<lbrakk>$H\<turnstile> $E, $F, a = b;  $H\<turnstile> $E, $F, b=c\<rbrakk> \<Longrightarrow> $H\<turnstile> $E, a = c, $F"
  by (rule trans [THEN R_of_imp, THEN mp_R])

(* Two theorms for rewriting only one instance of a definition:
   the first for definitions of formulae and the second for terms *)

lemma def_imp_iff: "(A \<equiv> B) \<Longrightarrow> \<turnstile> A \<longleftrightarrow> B"
  apply unfold
  apply (rule iff_refl)
  done

lemma meta_eq_to_obj_eq: "(A \<equiv> B) \<Longrightarrow> \<turnstile> A = B"
  apply unfold
  apply (rule refl)
  done

(** if-then-else rules **)

lemma if_True: "\<turnstile> (if True then x else y) = x"
  unfolding If_def by fast

lemma if_False: "\<turnstile> (if False then x else y) = y"
  unfolding If_def by fast

lemma if_P: "\<turnstile> P \<Longrightarrow> \<turnstile> (if P then x else y) = x"
  apply (unfold If_def)
  apply (erule thinR [THEN cut])
  apply fast
  done

lemma if_not_P: "\<turnstile> \<not> P \<Longrightarrow> \<turnstile> (if P then x else y) = y"
  apply (unfold If_def)
  apply (erule thinR [THEN cut])
  apply fast
  done

end