section \<open>Quantum instantiation of complements\<close>

theory Axioms_Complement_Quantum
  imports Laws_Quantum Finite_Tensor_Product Quantum_Extra
begin

no_notation m_inv ("inv\<index> _" [81] 80)
no_notation Lattice.join (infixl "\<squnion>\<index>" 65)

typedef ('a::finite,'b::finite) complement_domain = \<open>{..< if CARD('b) div CARD('a) \<noteq> 0 then CARD('b) div CARD('a) else 1}\<close>
  by auto

instance complement_domain :: (finite, finite) finite
proof intro_classes
  have \<open>inj Rep_complement_domain\<close>
    by (simp add: Rep_complement_domain_inject inj_on_def)
  moreover have \<open>finite (range Rep_complement_domain)\<close>
    by (metis finite_lessThan type_definition.Rep_range type_definition_complement_domain)
  ultimately show \<open>finite (UNIV :: ('a,'b) complement_domain set)\<close>
    using finite_image_iff by blast
qed

lemma CARD_complement_domain:
  assumes \<open>CARD('b::finite) = n * CARD('a::finite)\<close>
  shows \<open>CARD(('a,'b) complement_domain) = n\<close>
proof -
  from assms have \<open>n > 0\<close>
    by (metis zero_less_card_finite zero_less_mult_pos2)
  have *: \<open>inj Rep_complement_domain\<close>
    by (simp add: Rep_complement_domain_inject inj_on_def)
  moreover have \<open>card (range (Rep_complement_domain :: ('a,'b) complement_domain \<Rightarrow> _)) = n\<close>
    apply (subst type_definition.Rep_range[OF type_definition_complement_domain])
    using assms \<open>n > 0\<close> by simp
  ultimately show ?thesis
    by (metis card_image)
qed

lemma register_decomposition:
  fixes \<Phi> :: \<open>'a::finite update \<Rightarrow> 'b::finite update\<close>
  assumes [simp]: \<open>register \<Phi>\<close>
  shows \<open>\<exists>U :: ('a \<times> ('a, 'b) complement_domain) ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b ell2. unitary U \<and>
              (\<forall>\<theta>. \<Phi> \<theta> = sandwich U (\<theta> \<otimes>\<^sub>o id_cblinfun))\<close>
  \<comment> \<open>Proof based on \<^cite>\<open>daws21unitalanswer\<close>\<close>
proof -
  note [[simproc del: compatibility_warn]]
  fix \<xi>0 :: 'a

  have [simp]: \<open>clinear \<Phi>\<close>
    by simp

  define P where \<open>P i = Proj (ccspan {ket i})\<close> for i :: 'a
  have P_butter: \<open>P i = selfbutterket i\<close> for i
    by (simp add: P_def butterfly_eq_proj)

  define P' where \<open>P' i = \<Phi> (P i)\<close> for i :: 'a
  have proj_P': \<open>is_Proj (P' i)\<close> for i
    by (simp add: P_def P'_def register_projector)
  have \<open>(\<Sum>i\<in>UNIV. P i) = id_cblinfun\<close>
    using sum_butterfly_ket P_butter by simp
  then have sumP'id: \<open>(\<Sum>i\<in>UNIV. P' i) = id_cblinfun\<close>
    unfolding P'_def
    apply (subst complex_vector.linear_sum[OF \<open>clinear \<Phi>\<close>, symmetric])
    by auto

  define S where \<open>S i = P' i *\<^sub>S \<top>\<close> for i :: 'a
  have P'id: \<open>P' i *\<^sub>V \<psi> = \<psi>\<close> if \<open>\<psi> \<in> space_as_set (S i)\<close> for i \<psi>
    using S_def that proj_P'
    by (metis cblinfun_fixes_range is_Proj_algebraic)

  obtain B0 where finiteB0: \<open>finite (B0 i)\<close> and cspanB0: \<open>cspan (B0 i) = space_as_set (S i)\<close> for i
    apply atomize_elim apply (simp flip: all_conj_distrib) apply (rule choice)
    by (meson cfinite_dim_finite_subspace_basis csubspace_space_as_set)

  obtain B where orthoB: \<open>is_ortho_set (B i)\<close>
    and normalB: \<open>\<And>b. b \<in> B i \<Longrightarrow> norm b = 1\<close>
    and cspanB: \<open>cspan (B i) = cspan (B0 i)\<close>
    and finiteB: \<open>finite (B i)\<close> for i
    apply atomize_elim apply (simp flip: all_conj_distrib) apply (rule choice)
    using orthonormal_basis_of_cspan[OF finiteB0] by blast

  from cspanB cspanB0 have cspanB: \<open>cspan (B i) = space_as_set (S i)\<close> for i
    by simp
  then have ccspanB: \<open>ccspan (B i) = S i\<close> for i
    by (metis ccspan.rep_eq closure_finite_cspan finiteB space_as_set_inject)
  from orthoB have indepB: \<open>cindependent (B i)\<close> for i
    by (simp add: Complex_Inner_Product.is_ortho_set_cindependent)

  have orthoBiBj: \<open>is_orthogonal x y\<close> if \<open>x \<in> B i\<close> and \<open>y \<in> B j\<close> and \<open>i \<noteq> j\<close> for x y i j
  proof -
    from \<open>x \<in> B i\<close> obtain x' where x: \<open>x = P' i *\<^sub>V x'\<close>
      by (metis S_def cblinfun_fixes_range complex_vector.span_base cspanB is_Proj_idempotent proj_P')
    from \<open>y \<in> B j\<close> obtain y' where y: \<open>y = P' j *\<^sub>V y'\<close>
      by (metis S_def cblinfun_fixes_range complex_vector.span_base cspanB is_Proj_idempotent proj_P')
    have \<open>cinner x y = cinner (P' i *\<^sub>V x') (P' j *\<^sub>V  y')\<close>
      using x y by simp
    also have \<open>\<dots> = cinner (P' j *\<^sub>V P' i *\<^sub>V x') y'\<close>
      by (metis cinner_adj_left is_Proj_algebraic proj_P')
    also have \<open>\<dots> = cinner (\<Phi> (P j o\<^sub>C\<^sub>L P i) *\<^sub>V x') y'\<close>
      unfolding P'_def register_mult[OF \<open>register \<Phi>\<close>, symmetric] by simp
    also have \<open>\<dots> = cinner (\<Phi> (selfbutterket j o\<^sub>C\<^sub>L selfbutterket i) *\<^sub>V x') y'\<close>
      unfolding P_butter by simp
    also have \<open>\<dots> = cinner (\<Phi> 0 *\<^sub>V x') y'\<close>
      by (metis butterfly_comp_butterfly complex_vector.scale_eq_0_iff orthogonal_ket that(3))
    also have \<open>\<dots> = 0\<close>
      by (simp add: complex_vector.linear_0)
    finally show ?thesis
      by -
  qed

  define B' where \<open>B' = (\<Union>i\<in>UNIV. B i)\<close>

  have P'B: \<open>P' i = Proj (ccspan (B i))\<close> for i
    unfolding ccspanB S_def
    using proj_P' Proj_on_own_range'[symmetric] is_Proj_algebraic by blast

  have \<open>(\<Sum>i\<in>UNIV. P' i) = Proj (ccspan B')\<close>
  proof (unfold B'_def, use finite[of UNIV] in induction)
    case empty
    show ?case by auto
  next
    case (insert j M)
    have \<open>(\<Sum>i\<in>insert j M. P' i) = P' j + (\<Sum>i\<in>M. P' i)\<close>
      by (meson insert.hyps(1) insert.hyps(2) sum.insert)
    also have \<open>\<dots> = Proj (ccspan (B j)) + Proj (ccspan (\<Union>i\<in>M. B i))\<close>
      unfolding P'B insert.IH[symmetric] by simp
    also have \<open>\<dots> = Proj (ccspan (B j \<union> (\<Union>i\<in>M. B i)))\<close>
      apply (rule Proj_orthog_ccspan_union[symmetric])
      using orthoBiBj insert.hyps(2) by auto
    also have \<open>\<dots> = Proj (ccspan (\<Union>i\<in>insert j M. B i))\<close>
      by auto
    finally show ?case
      by simp
  qed

  with sumP'id
  have ccspanB': \<open>ccspan B' = \<top>\<close>
    by (metis Proj_range cblinfun_image_id)
  hence cspanB': \<open>cspan B' = UNIV\<close>
    by (metis B'_def finiteB ccspan.rep_eq finite_UN_I finite_class.finite_UNIV closure_finite_cspan top_ccsubspace.rep_eq)

  from orthoBiBj orthoB have orthoB': \<open>is_ortho_set B'\<close>
    unfolding B'_def is_ortho_set_def by blast
  then have indepB': \<open>cindependent B'\<close>
    using is_ortho_set_cindependent by blast
  have cardB': \<open>card B' = CARD('b)\<close>
    apply (subst complex_vector.dim_span_eq_card_independent[symmetric])
     apply (rule indepB')
    apply (subst cspanB')
    using cdim_UNIV_ell2 by auto

  from orthoBiBj orthoB
  have Bdisj: \<open>B i \<inter> B j = {}\<close> if \<open>i \<noteq> j\<close> for i j
    unfolding is_ortho_set_def
    apply auto by (metis cinner_eq_zero_iff that)

  have cardBsame: \<open>card (B i) = card (B j)\<close> for i j
  proof -
    define Si_to_Sj where \<open>Si_to_Sj i j \<psi> = \<Phi> (butterket j i) *\<^sub>V \<psi>\<close> for i j \<psi>
    have S2S2S: \<open>Si_to_Sj j i (Si_to_Sj i j \<psi>) = \<psi>\<close> if \<open>\<psi> \<in> space_as_set (S i)\<close> for i j \<psi>
      using that P'id
      by (simp add: Si_to_Sj_def cblinfun_apply_cblinfun_compose[symmetric] register_mult P_butter P'_def)
    also have lin[simp]: \<open>clinear (Si_to_Sj i j)\<close> for i j
      unfolding Si_to_Sj_def by simp
    have S2S: \<open>Si_to_Sj i j x \<in> space_as_set (S j)\<close> for i j x
    proof -
      have \<open>Si_to_Sj i j x = P' j *\<^sub>V Si_to_Sj i j x\<close>
        by (simp add: Si_to_Sj_def cblinfun_apply_cblinfun_compose[symmetric] register_mult P_butter P'_def)
      also have \<open>P' j *\<^sub>V Si_to_Sj i j x \<in> space_as_set (S j)\<close>
        by (simp add: S_def)
      finally show ?thesis by -
    qed
    have bij: \<open>bij_betw (Si_to_Sj i j) (space_as_set (S i)) (space_as_set (S j))\<close>
      apply (rule bij_betwI[where g=\<open>Si_to_Sj j i\<close>])
      using S2S S2S2S by (auto intro!: funcsetI)
    have \<open>cdim (space_as_set (S i)) = cdim (space_as_set (S j))\<close>
      using lin apply (rule isomorphic_equal_cdim[where f=\<open>Si_to_Sj i j\<close>])
      using bij apply (auto simp: bij_betw_def)
      by (metis complex_vector.span_span cspanB)
    then show ?thesis
      by (metis complex_vector.dim_span_eq_card_independent cspanB indepB)
  qed

  have CARD'b: \<open>CARD('b) = card (B \<xi>0) * CARD('a)\<close>
  proof -
    have \<open>CARD('b) = card B'\<close>
      using cardB' by simp
    also have \<open>\<dots> = (\<Sum>i\<in>UNIV. card (B i))\<close>
      unfolding B'_def apply (rule card_UN_disjoint)
      using finiteB Bdisj by auto
    also have \<open>\<dots> = (\<Sum>(i::'a)\<in>UNIV. card (B \<xi>0))\<close>
      using cardBsame by metis
    also have \<open>\<dots> = card (B \<xi>0) * CARD('a)\<close>
      by auto
    finally show ?thesis by -
  qed

  obtain f where bij_f: \<open>bij_betw f (UNIV::('a,'b) complement_domain set) (B \<xi>0)\<close>
    apply atomize_elim apply (rule finite_same_card_bij)
    using finiteB CARD_complement_domain[OF CARD'b] by auto

  define u where \<open>u = (\<lambda>(\<xi>,\<alpha>). \<Phi> (butterket \<xi> \<xi>0) *\<^sub>V f \<alpha>)\<close> for \<xi> :: 'a and \<alpha> :: \<open>('a,'b) complement_domain\<close>
  obtain U where Uapply: \<open>U *\<^sub>V ket \<xi>\<alpha> = u \<xi>\<alpha>\<close> for \<xi>\<alpha>
    apply atomize_elim
    apply (rule exI[of _ \<open>cblinfun_extension (range ket) (\<lambda>k. u (inv ket k))\<close>])
    apply (subst cblinfun_extension_apply)
      apply (rule cblinfun_extension_exists_finite_dim)
    by (auto simp add: inj_ket cindependent_ket)

  define eqa where \<open>eqa a b = (if a = b then 1 else 0 :: complex)\<close> for a b :: 'a
  define eqc where \<open>eqc a b = (if a = b then 1 else 0 :: complex)\<close> for a b :: \<open>('a,'b) complement_domain\<close>
  define eqac where \<open>eqac a b = (if a = b then 1 else 0 :: complex)\<close> for a b :: \<open>'a * ('a,'b) complement_domain\<close>

  have \<open>cinner (U *\<^sub>V ket \<xi>\<alpha>) (U *\<^sub>V ket \<xi>'\<alpha>') = eqac \<xi>\<alpha> \<xi>'\<alpha>'\<close> for \<xi>\<alpha> \<xi>'\<alpha>'
  proof -
    obtain \<xi> \<alpha> \<xi>' \<alpha>' where \<xi>\<alpha>: \<open>\<xi>\<alpha> = (\<xi>,\<alpha>)\<close> and \<xi>'\<alpha>': \<open>\<xi>'\<alpha>' = (\<xi>',\<alpha>')\<close>
      apply atomize_elim by auto
    have \<open>cinner (U *\<^sub>V ket (\<xi>,\<alpha>)) (U *\<^sub>V ket (\<xi>', \<alpha>')) = cinner (\<Phi> (butterket \<xi> \<xi>0) *\<^sub>V f \<alpha>) (\<Phi> (butterket \<xi>' \<xi>0) *\<^sub>V f \<alpha>')\<close>
      unfolding Uapply u_def by simp
    also have \<open>\<dots> = cinner ((\<Phi> (butterket \<xi>' \<xi>0))* *\<^sub>V \<Phi> (butterket \<xi> \<xi>0) *\<^sub>V f \<alpha>) (f \<alpha>')\<close>
      by (simp add: cinner_adj_left)
    also have \<open>\<dots> = cinner (\<Phi> (butterket \<xi>' \<xi>0 *) *\<^sub>V \<Phi> (butterket \<xi> \<xi>0) *\<^sub>V f \<alpha>) (f \<alpha>')\<close>
      by (metis (no_types, lifting) assms register_def)
    also have \<open>\<dots> = cinner (\<Phi> (butterket \<xi>0 \<xi>' o\<^sub>C\<^sub>L butterket \<xi> \<xi>0) *\<^sub>V f \<alpha>) (f \<alpha>')\<close>
      by (simp add: register_mult cblinfun_apply_cblinfun_compose[symmetric])
    also have \<open>\<dots> = cinner (\<Phi> (eqa \<xi>' \<xi> *\<^sub>C selfbutterket \<xi>0) *\<^sub>V f \<alpha>) (f \<alpha>')\<close>
      apply simp by (metis eqa_def cinner_ket)
    also have \<open>\<dots> = eqa \<xi>' \<xi> * cinner (\<Phi> (selfbutterket \<xi>0) *\<^sub>V f \<alpha>) (f \<alpha>')\<close>
      by (smt (verit, ccfv_threshold) \<open>clinear \<Phi>\<close> eqa_def cblinfun.scaleC_left cinner_commute
              cinner_scaleC_left cinner_zero_right complex_cnj_one complex_vector.linear_scale)
    also have \<open>\<dots> = eqa \<xi>' \<xi> * cinner (P' \<xi>0 *\<^sub>V f \<alpha>) (f \<alpha>')\<close>
      using P_butter P'_def by simp
    also have \<open>\<dots> = eqa \<xi>' \<xi> * cinner (f \<alpha>) (f \<alpha>')\<close>
      apply (subst P'id)
       apply (metis bij_betw_imp_surj_on bij_f complex_vector.span_base cspanB rangeI)
      by simp
    also have \<open>\<dots> = eqa \<xi>' \<xi> * eqc \<alpha> \<alpha>'\<close>
      using bij_f orthoB normalB unfolding is_ortho_set_def eqc_def apply auto
       apply (metis bij_betw_imp_surj_on cnorm_eq_1 rangeI)
      by (smt (z3) bij_betw_iff_bijections iso_tuple_UNIV_I)
    finally show ?thesis
      by (simp add: eqa_def eqac_def eqc_def \<xi>'\<alpha>' \<xi>\<alpha>)
  qed
  then have \<open>isometry U\<close>
    apply (rule_tac orthogonal_on_basis_is_isometry[where B=\<open>range ket\<close>])
    using eqac_def by auto

  have \<open>U* o\<^sub>C\<^sub>L \<Phi> (butterket \<xi> \<eta>) o\<^sub>C\<^sub>L U = butterket \<xi> \<eta> \<otimes>\<^sub>o id_cblinfun\<close> for \<xi> \<eta>
  proof (rule equal_ket, rename_tac \<xi>1\<alpha>)
    fix \<xi>1\<alpha> obtain \<xi>1 :: 'a and \<alpha> :: \<open>('a,'b) complement_domain\<close> where \<xi>1\<alpha>: \<open>\<xi>1\<alpha> = (\<xi>1,\<alpha>)\<close>
      apply atomize_elim by auto
    have \<open>(U* o\<^sub>C\<^sub>L \<Phi> (butterket \<xi> \<eta>) o\<^sub>C\<^sub>L U) *\<^sub>V ket \<xi>1\<alpha> = U* *\<^sub>V \<Phi> (butterket \<xi> \<eta>) *\<^sub>V \<Phi> (butterket \<xi>1 \<xi>0) *\<^sub>V f \<alpha>\<close>
      unfolding cblinfun_apply_cblinfun_compose \<xi>1\<alpha> Uapply u_def by simp
    also have \<open>\<dots> = U* *\<^sub>V \<Phi> (butterket \<xi> \<eta> o\<^sub>C\<^sub>L butterket \<xi>1 \<xi>0) *\<^sub>V f \<alpha>\<close>
      by (metis (no_types, lifting) assms butterfly_comp_butterfly lift_cblinfun_comp(4) register_mult)
    also have \<open>\<dots> = U* *\<^sub>V \<Phi> (eqa \<eta> \<xi>1 *\<^sub>C butterket \<xi> \<xi>0) *\<^sub>V f \<alpha>\<close>
      by (simp add: eqa_def cinner_ket)
    also have \<open>\<dots> = eqa \<eta> \<xi>1 *\<^sub>C U* *\<^sub>V \<Phi> (butterket \<xi> \<xi>0) *\<^sub>V f \<alpha>\<close>
      by (simp add: complex_vector.linear_scale)
    also have \<open>\<dots> = eqa \<eta> \<xi>1 *\<^sub>C U* *\<^sub>V U *\<^sub>V ket (\<xi>, \<alpha>)\<close>
      unfolding Uapply u_def by simp
    also from \<open>isometry U\<close> have \<open>\<dots> = eqa \<eta> \<xi>1 *\<^sub>C ket (\<xi>, \<alpha>)\<close>
      unfolding cblinfun_apply_cblinfun_compose[symmetric] by simp
    also have \<open>\<dots> = (butterket \<xi> \<eta> *\<^sub>V ket \<xi>1) \<otimes>\<^sub>s ket \<alpha>\<close>
      by (simp add: eqa_def tensor_ell2_scaleC1)
    also have \<open>\<dots> = (butterket \<xi> \<eta> \<otimes>\<^sub>o id_cblinfun) *\<^sub>V ket \<xi>1\<alpha>\<close>
      by (simp add: \<xi>1\<alpha> tensor_op_ket)
    finally show \<open>(U* o\<^sub>C\<^sub>L \<Phi> (butterket \<xi> \<eta>) o\<^sub>C\<^sub>L U) *\<^sub>V ket \<xi>1\<alpha> = (butterket \<xi> \<eta> \<otimes>\<^sub>o id_cblinfun) *\<^sub>V ket \<xi>1\<alpha>\<close>
      by -
  qed
  then have 1: \<open>U* o\<^sub>C\<^sub>L \<Phi> \<theta> o\<^sub>C\<^sub>L U = \<theta> \<otimes>\<^sub>o id_cblinfun\<close> for \<theta>
    apply (rule_tac clinear_eq_butterfly_ketI[THEN fun_cong, where x=\<theta>])
    by (auto intro!: clinearI simp add: bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose complex_vector.linear_add complex_vector.linear_scale)

  have \<open>unitary U\<close>
  proof -
    have \<open>\<Phi> (butterket \<xi> \<xi>1) *\<^sub>S \<top> \<le> U *\<^sub>S \<top>\<close> for \<xi> \<xi>1
    proof -
      have *: \<open>\<Phi> (butterket \<xi> \<xi>0) *\<^sub>V b \<in> space_as_set (U *\<^sub>S \<top>)\<close> if \<open>b \<in> B \<xi>0\<close> for b
        apply (subst asm_rl[of \<open>\<Phi> (butterket \<xi> \<xi>0) *\<^sub>V b = u (\<xi>, inv f b)\<close>])
         apply (simp add: u_def, metis bij_betw_inv_into_right bij_f that)
        by (metis Uapply cblinfun_apply_in_image)

      have \<open>\<Phi> (butterket \<xi> \<xi>1) *\<^sub>S \<top> = \<Phi> (butterket \<xi> \<xi>0) *\<^sub>S \<Phi> (butterket \<xi>0 \<xi>0) *\<^sub>S \<Phi> (butterket \<xi>0 \<xi>1) *\<^sub>S \<top>\<close>
        unfolding cblinfun_compose_image[symmetric] register_mult[OF assms]
        by simp
      also have \<open>\<dots> \<le> \<Phi> (butterket \<xi> \<xi>0) *\<^sub>S \<Phi> (butterket \<xi>0 \<xi>0) *\<^sub>S \<top>\<close>
        by (meson cblinfun_image_mono top_greatest)
      also have \<open>\<dots> = \<Phi> (butterket \<xi> \<xi>0) *\<^sub>S S \<xi>0\<close>
        by (simp add: S_def P'_def P_butter)
      also have \<open>\<dots> = \<Phi> (butterket \<xi> \<xi>0) *\<^sub>S ccspan (B \<xi>0)\<close>
        by (simp add: ccspanB)
      also have \<open>\<dots> = ccspan (\<Phi> (butterket \<xi> \<xi>0) ` B \<xi>0)\<close>
        by (meson cblinfun_image_ccspan)
      also have \<open>\<dots> \<le> U *\<^sub>S \<top>\<close>
        by (rule ccspan_leqI, use * in auto)
      finally show ?thesis by -
    qed
    moreover have \<open>\<Phi> id_cblinfun *\<^sub>S \<top> \<le> (SUP \<xi>\<in>UNIV. \<Phi> (selfbutterket \<xi>) *\<^sub>S \<top>)\<close>
      unfolding sum_butterfly_ket[symmetric]
      apply (subst complex_vector.linear_sum, simp)
      by (rule cblinfun_sum_image_distr)
    ultimately have \<open>\<Phi> id_cblinfun *\<^sub>S \<top> \<le> U *\<^sub>S \<top>\<close>
      apply auto by (meson SUP_le_iff order.trans)
    then have \<open>U *\<^sub>S \<top> = \<top>\<close>
      apply auto
      using top.extremum_unique by blast
    with \<open>isometry U\<close> show \<open>unitary U\<close>
      by (rule surj_isometry_is_unitary)
  qed

  have \<open>\<Phi> \<theta> = U o\<^sub>C\<^sub>L (\<theta> \<otimes>\<^sub>o id_cblinfun) o\<^sub>C\<^sub>L U*\<close> for \<theta>
  proof -
    from \<open>unitary U\<close>
    have \<open>\<Phi> \<theta> = (U o\<^sub>C\<^sub>L U*) o\<^sub>C\<^sub>L \<Phi> \<theta> o\<^sub>C\<^sub>L (U o\<^sub>C\<^sub>L U*)\<close>
      by simp
    also have \<open>\<dots> = U o\<^sub>C\<^sub>L (U*  o\<^sub>C\<^sub>L \<Phi> \<theta> o\<^sub>C\<^sub>L U) o\<^sub>C\<^sub>L U*\<close>
      by (simp add: cblinfun_assoc_left)
    also have \<open>\<dots> = U o\<^sub>C\<^sub>L (\<theta> \<otimes>\<^sub>o id_cblinfun) o\<^sub>C\<^sub>L U*\<close>
      using 1 by simp
    finally show ?thesis
      by -
  qed

  with \<open>unitary U\<close> show ?thesis
    by (auto simp: sandwich_def)
qed

lemma register_decomposition_converse:
  assumes \<open>unitary U\<close>
  shows \<open>register (\<lambda>x. sandwich U (id_cblinfun \<otimes>\<^sub>o x))\<close>
  using _ unitary_sandwich_register apply (rule register_comp[unfolded o_def])
  using assms by auto

lemma register_inj: \<open>inj F\<close> if \<open>register F\<close>
proof -
  obtain U :: \<open>('a \<times> ('a, 'b) complement_domain) ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b ell2\<close>
    where \<open>unitary U\<close> and F: \<open>F a = sandwich U (a \<otimes>\<^sub>o id_cblinfun)\<close> for a
    apply atomize_elim using \<open>register F\<close> by (rule register_decomposition)
  have \<open>inj (sandwich U)\<close>
    by (smt (verit, best) \<open>unitary U\<close> cblinfun_assoc_left inj_onI sandwich_def cblinfun_compose_id_right cblinfun_compose_id_left unitary_def)
  moreover have \<open>inj (\<lambda>a::'a::finite ell2 \<Rightarrow>\<^sub>C\<^sub>L _. a \<otimes>\<^sub>o id_cblinfun)\<close>
    by (rule inj_tensor_left, simp)
  ultimately show \<open>inj F\<close>
    unfolding F
    by (smt (z3) inj_def)
qed

lemma iso_register_decomposition:
  assumes [simp]: \<open>iso_register F\<close>
  shows \<open>\<exists>U. unitary U \<and> F = sandwich U\<close>
proof -
  have [simp]: \<open>register F\<close>
    using assms iso_register_is_register by blast

  let ?ida = \<open>id_cblinfun :: ('a, 'b) complement_domain ell2 \<Rightarrow>\<^sub>C\<^sub>L _\<close>

  from register_decomposition[OF \<open>register F\<close>]
  obtain V :: \<open>('a \<times> ('a, 'b) complement_domain) ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b ell2\<close> where \<open>unitary V\<close>
    and FV: \<open>F \<theta> = sandwich V (\<theta> \<otimes>\<^sub>o ?ida)\<close> for \<theta>
    by auto

  have \<open>surj F\<close>
    by (meson assms iso_register_inv_comp2 surj_iff)
  have surj_tensor: \<open>surj (\<lambda>a::'a ell2 \<Rightarrow>\<^sub>C\<^sub>L 'a ell2. a \<otimes>\<^sub>o ?ida)\<close>
    apply (rule surj_from_comp[where g=\<open>sandwich V\<close>])
    using \<open>surj F\<close> apply (auto simp: FV)
    by (meson \<open>unitary V\<close> register_inj unitary_sandwich_register)
  then obtain a :: \<open>'a ell2 \<Rightarrow>\<^sub>C\<^sub>L _\<close>
    where a: \<open>a \<otimes>\<^sub>o ?ida = selfbutterket undefined \<otimes>\<^sub>o selfbutterket undefined\<close>
    by (smt (verit, best) surjD)

  then have \<open>a \<noteq> 0\<close>
    apply auto
    by (metis butterfly_apply cblinfun.zero_left complex_vector.scale_eq_0_iff ket_nonzero orthogonal_ket)

  obtain \<gamma> where \<gamma>: \<open>?ida = \<gamma> *\<^sub>C selfbutterket undefined\<close>
    apply atomize_elim
    using a \<open>a \<noteq> 0\<close> by (rule tensor_op_almost_injective)
  then have \<open>?ida (ket undefined) = \<gamma> *\<^sub>C (selfbutterket undefined *\<^sub>V ket undefined)\<close>
    by (simp add: \<open>id_cblinfun = \<gamma> *\<^sub>C selfbutterket undefined\<close> scaleC_cblinfun.rep_eq)
  then have \<open>ket undefined = \<gamma> *\<^sub>C ket undefined\<close>
    by (metis butterfly_apply cinner_scaleC_right id_cblinfun_apply cinner_ket_same mult.right_neutral scaleC_one)
  then have \<open>\<gamma> = 1\<close>
    by (smt (z3) \<gamma> butterfly_apply butterfly_scaleC_left cblinfun_id_cblinfun_apply complex_vector.scale_cancel_right cinner_ket_same ket_nonzero)

  define T U where \<open>T = CBlinfun (\<lambda>\<psi>. \<psi> \<otimes>\<^sub>s ket undefined)\<close> and \<open>U = V o\<^sub>C\<^sub>L T\<close>
  have T: \<open>T \<psi> = \<psi> \<otimes>\<^sub>s ket undefined\<close> for \<psi>
    unfolding T_def
    apply (subst bounded_clinear_CBlinfun_apply)
    by (auto intro!: bounded_clinear_finite_dim clinear_tensor_ell22)
  have sandwich_T: \<open>sandwich T a = a \<otimes>\<^sub>o ?ida\<close> for a
    apply (rule fun_cong[where x=a])
    apply (rule clinear_eq_butterfly_ketI)
      apply auto
    by (metis (no_types, opaque_lifting) Misc.sandwich_def T \<gamma> \<open>\<gamma> = 1\<close> adj_cblinfun_compose butterfly_adjoint cblinfun_comp_butterfly scaleC_one tensor_butterfly)

  have \<open>F (butterfly x y) = V o\<^sub>C\<^sub>L (butterfly x y \<otimes>\<^sub>o ?ida) o\<^sub>C\<^sub>L V*\<close> for x y
    by (simp add: Misc.sandwich_def FV)
  also have \<open>\<dots> x y = V o\<^sub>C\<^sub>L (butterfly (T x) (T y)) o\<^sub>C\<^sub>L V*\<close> for x y
    by (simp add: T \<gamma> \<open>\<gamma> = 1\<close>)
  also have \<open>\<dots> x y = U o\<^sub>C\<^sub>L (butterfly x y) o\<^sub>C\<^sub>L U*\<close> for x y
    by (simp add: U_def butterfly_comp_cblinfun cblinfun_comp_butterfly)
  finally have F_rep:  \<open>F a = U o\<^sub>C\<^sub>L a o\<^sub>C\<^sub>L U*\<close> for a
    apply (rule_tac fun_cong[where x=a])
    apply (rule_tac clinear_eq_butterfly_ketI)
      apply auto
    by (metis (no_types, lifting) cblinfun_apply_clinear clinear_iff sandwich_apply)

  have \<open>isometry T\<close>
    apply (rule orthogonal_on_basis_is_isometry[where B=\<open>range ket\<close>])
    by (auto simp: T)
  moreover have \<open>T *\<^sub>S \<top> = \<top>\<close>
  proof -
    have 1: \<open>\<phi> \<otimes>\<^sub>s \<xi> \<in> range ((*\<^sub>V) T)\<close> for \<phi> \<xi>
    proof -
      have \<open>T *\<^sub>V (cinner (ket undefined) \<xi> *\<^sub>C \<phi>) = \<phi> \<otimes>\<^sub>s (cinner (ket undefined) \<xi> *\<^sub>C ket undefined)\<close>
        by (simp add: T tensor_ell2_scaleC2)
      also have \<open>\<dots> = \<phi> \<otimes>\<^sub>s (selfbutterket undefined *\<^sub>V \<xi>)\<close>
        by simp
      also have \<open>\<dots> = \<phi> \<otimes>\<^sub>s (?ida *\<^sub>V \<xi>)\<close>
        by (simp add: \<gamma> \<open>\<gamma> = 1\<close>)
      also have \<open>\<dots> = \<phi> \<otimes>\<^sub>s \<xi>\<close>
        by simp
      finally show ?thesis
        by (metis range_eqI)
    qed

    have \<open>\<top> \<le> ccspan {ket x | x. True}\<close>
      by (simp add: full_SetCompr_eq)
    also have \<open>\<dots> \<le> ccspan {\<phi> \<otimes>\<^sub>s \<xi> | \<phi> \<xi>. True}\<close>
      apply (rule ccspan_mono)
      by (auto simp flip: tensor_ell2_ket)
    also from 1 have \<open>\<dots> \<le> ccspan (range ((*\<^sub>V) T))\<close>
      by (auto intro!: ccspan_mono)
    also have \<open>\<dots> = T *\<^sub>S \<top>\<close>
      by (metis (mono_tags, opaque_lifting) calculation cblinfun_image_ccspan cblinfun_image_mono eq_iff top_greatest)
    finally show \<open>T *\<^sub>S \<top> = \<top>\<close>
      using top.extremum_uniqueI by blast
  qed

  ultimately have \<open>unitary T\<close>
    by (rule surj_isometry_is_unitary)
  then have \<open>unitary U\<close>
    by (simp add: U_def \<open>unitary V\<close>)

  from F_rep \<open>unitary U\<close> show ?thesis
    by (auto simp: sandwich_def[abs_def])
qed

lemma complement_exists:
  fixes F :: \<open>'a::finite update \<Rightarrow> 'b::finite update\<close>
  assumes \<open>register F\<close>
  shows \<open>\<exists>G :: ('a, 'b) complement_domain update \<Rightarrow> 'b update. compatible F G \<and> iso_register (F;G)\<close>
proof -
  note [[simproc del: Laws_Quantum.compatibility_warn]]
  obtain U :: \<open>('a \<times> ('a, 'b) complement_domain) ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b ell2\<close>
    where [simp]: "unitary U" and F: \<open>F a = sandwich U (a \<otimes>\<^sub>o id_cblinfun)\<close> for a
    apply atomize_elim using assms by (rule register_decomposition)
  define G :: \<open>(('a, 'b) complement_domain) update \<Rightarrow> 'b update\<close> where \<open>G b = sandwich U (id_cblinfun \<otimes>\<^sub>o b)\<close> for b
  have [simp]: \<open>register G\<close>
    unfolding G_def apply (rule register_decomposition_converse) by simp
  have \<open>F a o\<^sub>C\<^sub>L G b = G b o\<^sub>C\<^sub>L F a\<close> for a b
  proof -
    have \<open>F a o\<^sub>C\<^sub>L G b = sandwich U (a \<otimes>\<^sub>o b)\<close>
      apply (auto simp: F G_def sandwich_def)
      by (metis (no_types, lifting) \<open>unitary U\<close> isometryD cblinfun_assoc_left(1) comp_tensor_op cblinfun_compose_id_right cblinfun_compose_id_left unitary_isometry)
    moreover have \<open>G b o\<^sub>C\<^sub>L F a = sandwich U (a \<otimes>\<^sub>o b)\<close>
      apply (auto simp: F G_def sandwich_def)
      by (metis (no_types, lifting) \<open>unitary U\<close> isometryD cblinfun_assoc_left(1) comp_tensor_op cblinfun_compose_id_right cblinfun_compose_id_left unitary_isometry)
    ultimately show ?thesis by simp
  qed
  then have [simp]: \<open>compatible F G\<close>
    by (auto simp: compatible_def \<open>register F\<close> \<open>register G\<close>)
  moreover have \<open>iso_register (F;G)\<close>
  proof -
    have \<open>(F;G) (a \<otimes>\<^sub>o b) = sandwich U (a \<otimes>\<^sub>o b)\<close> for a b
      apply (auto simp: register_pair_apply F G_def sandwich_def)
      by (metis (no_types, lifting) \<open>unitary U\<close> isometryD cblinfun_assoc_left(1) comp_tensor_op cblinfun_compose_id_right cblinfun_compose_id_left unitary_isometry)
    then have FG: \<open>(F;G) = sandwich U\<close>
      apply (rule tensor_extensionality[rotated -1])
      by (simp_all add: bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose bounded_cbilinear.add_right clinearI)
    define I where \<open>I = sandwich (U*)\<close> for x
    have [simp]: \<open>register I\<close>
      by (simp add: I_def unitary_sandwich_register)
    have \<open>I o (F;G) = id\<close> and FGI: \<open>(F;G) o I = id\<close>
       apply (auto intro!:ext simp: I_def[abs_def] FG sandwich_def)
       apply (metis (no_types, opaque_lifting) \<open>unitary U\<close> isometryD cblinfun_assoc_left(1) cblinfun_compose_id_right cblinfun_compose_id_left unitary_isometry)
      by (metis (no_types, lifting) \<open>unitary U\<close> cblinfun_assoc_left(1) cblinfun_compose_id_left cblinfun_compose_id_right unitaryD2)
    then show \<open>iso_register (F;G)\<close>
      by (auto intro!: iso_registerI)
  qed
  ultimately show ?thesis
    apply (rule_tac exI[of _ G]) by (auto)
qed

definition \<open>commutant F = {x. \<forall>y\<in>F. x o\<^sub>C\<^sub>L y = y o\<^sub>C\<^sub>L x}\<close>

lemma commutant_exchange:
  fixes F :: \<open>'a::finite update \<Rightarrow> 'b::finite update\<close>
  assumes \<open>iso_register F\<close>
  shows \<open>commutant (F ` X) = F ` commutant X\<close>
proof (rule Set.set_eqI)
  fix x :: \<open>'b update\<close>
  from assms
  obtain G where \<open>F o G = id\<close> and \<open>G o F = id\<close> and [simp]: \<open>register G\<close>
    using iso_register_def by blast
  from assms have [simp]: \<open>register F\<close>
    using iso_register_def by blast
  have \<open>x \<in> commutant (F ` X) \<longleftrightarrow> (\<forall>y \<in> F ` X. x o\<^sub>C\<^sub>L y = y o\<^sub>C\<^sub>L x)\<close>
    by (simp add: commutant_def)
  also have \<open>\<dots> \<longleftrightarrow> (\<forall>y \<in> F ` X. G x o\<^sub>C\<^sub>L G y = G y o\<^sub>C\<^sub>L G x)\<close>
    by (metis (no_types, opaque_lifting) \<open>F \<circ> G = id\<close> \<open>G o F = id\<close> \<open>register G\<close> comp_def eq_id_iff register_def)
  also have \<open>\<dots> \<longleftrightarrow> (\<forall>y \<in> X. G x o\<^sub>C\<^sub>L y = y o\<^sub>C\<^sub>L G x)\<close>
    by (simp add: \<open>G \<circ> F = id\<close> pointfree_idE)
  also have \<open>\<dots> \<longleftrightarrow> G x \<in> commutant X\<close>
    by (simp add: commutant_def)
  also have \<open>\<dots> \<longleftrightarrow> x \<in> F ` commutant X\<close>
    by (metis (no_types, opaque_lifting) \<open>G \<circ> F = id\<close> \<open>F \<circ> G = id\<close> image_iff pointfree_idE)
  finally show \<open>x \<in> commutant (F ` X) \<longleftrightarrow> x \<in> F ` commutant X\<close>
    by -
qed

lemma commutant_tensor1: \<open>commutant (range (\<lambda>a. a \<otimes>\<^sub>o id_cblinfun)) = range (\<lambda>b. id_cblinfun \<otimes>\<^sub>o b)\<close>
proof (rule Set.set_eqI, rule iffI)
  fix x :: \<open>('a \<times> 'b) ell2 \<Rightarrow>\<^sub>C\<^sub>L ('a \<times> 'b) ell2\<close>
  fix \<gamma> :: 'a
  assume \<open>x \<in> commutant (range (\<lambda>a. a \<otimes>\<^sub>o id_cblinfun))\<close>
  then have comm: \<open>(a \<otimes>\<^sub>o id_cblinfun) *\<^sub>V x *\<^sub>V \<psi> = x *\<^sub>V (a \<otimes>\<^sub>o id_cblinfun) *\<^sub>V \<psi>\<close> for a \<psi>
    by (metis (mono_tags, lifting) commutant_def mem_Collect_eq rangeI cblinfun_apply_cblinfun_compose)

  obtain x' where x': \<open>cinner (ket j) (x' *\<^sub>V ket l) = cinner (ket (\<gamma>,j)) (x *\<^sub>V ket (\<gamma>,l))\<close> for j l
  proof atomize_elim
    obtain \<psi> where \<psi>: \<open>cinner (ket j) (\<psi> l) = cinner (ket (\<gamma>, j)) (x *\<^sub>V ket (\<gamma>, l))\<close> for l j
      apply (atomize_elim, rule choice, rule allI)
      apply (rule_tac x=\<open>Abs_ell2 (\<lambda>j. cinner (ket (\<gamma>, j)) (x *\<^sub>V ket (\<gamma>, l)))\<close> in exI)
      by (simp add: cinner_ket_left Abs_ell2_inverse)
    obtain x' where \<open>x' *\<^sub>V ket l = \<psi> l\<close> for l
      apply atomize_elim
      apply (rule exI[of _ \<open>cblinfun_extension (range ket) (\<lambda>l. \<psi> (inv ket l))\<close>])
      apply (subst cblinfun_extension_apply)
        apply (rule cblinfun_extension_exists_finite_dim)
      by (auto simp add: inj_ket cindependent_ket)
    with \<psi> have \<open>cinner (ket j) (x' *\<^sub>V ket l) = cinner (ket (\<gamma>, j)) (x *\<^sub>V ket (\<gamma>, l))\<close> for j l
      by auto
    then show \<open>\<exists>x'. \<forall>j l. cinner (ket j) (x' *\<^sub>V ket l) = cinner (ket (\<gamma>, j)) (x *\<^sub>V ket (\<gamma>, l))\<close>
      by auto
  qed

  have \<open>cinner (ket (i,j)) (x *\<^sub>V ket (k,l)) = cinner (ket (i,j)) ((id_cblinfun \<otimes>\<^sub>o x') *\<^sub>V ket (k,l))\<close> for i j k l
  proof -
    have \<open>cinner (ket (i,j)) (x *\<^sub>V ket (k,l))
        = cinner ((butterket i \<gamma> \<otimes>\<^sub>o id_cblinfun) *\<^sub>V ket (\<gamma>,j)) (x *\<^sub>V (butterket k \<gamma> \<otimes>\<^sub>o id_cblinfun) *\<^sub>V ket (\<gamma>,l))\<close>
      by (auto simp: tensor_op_ket)
    also have \<open>\<dots> = cinner (ket (\<gamma>,j)) ((butterket \<gamma> i \<otimes>\<^sub>o id_cblinfun) *\<^sub>V x *\<^sub>V (butterket k \<gamma> \<otimes>\<^sub>o id_cblinfun) *\<^sub>V ket (\<gamma>,l))\<close>
      by (metis (no_types, lifting) cinner_adj_left butterfly_adjoint id_cblinfun_adjoint tensor_op_adjoint)
    also have \<open>\<dots> = cinner (ket (\<gamma>,j)) (x *\<^sub>V (butterket \<gamma> i \<otimes>\<^sub>o id_cblinfun o\<^sub>C\<^sub>L butterket k \<gamma> \<otimes>\<^sub>o id_cblinfun) *\<^sub>V ket (\<gamma>,l))\<close>
      unfolding comm by (simp add: cblinfun_apply_cblinfun_compose)
    also have \<open>\<dots> = cinner (ket i) (ket k) * cinner (ket (\<gamma>,j)) (x *\<^sub>V ket (\<gamma>,l))\<close>
      by (simp add: comp_tensor_op tensor_op_ket tensor_op_scaleC_left)
    also have \<open>\<dots> = cinner (ket i) (ket k) * cinner (ket j) (x' *\<^sub>V ket l)\<close>
      by (simp add: x')
    also have \<open>\<dots> = cinner (ket (i,j)) ((id_cblinfun \<otimes>\<^sub>o x') *\<^sub>V ket (k,l))\<close>
      apply (simp add: tensor_op_ket)
      by (simp flip: tensor_ell2_ket)
    finally show ?thesis by -
  qed
  then have \<open>x = (id_cblinfun \<otimes>\<^sub>o x')\<close>
    by (auto intro!: equal_ket cinner_ket_eqI)
  then show \<open>x \<in> range (\<lambda>b. id_cblinfun \<otimes>\<^sub>o b)\<close>
    by auto
next
  fix x :: \<open>('a \<times> 'b) ell2 \<Rightarrow>\<^sub>C\<^sub>L ('a \<times> 'b) ell2\<close>
  assume \<open>x \<in> range (\<lambda>b. id_cblinfun \<otimes>\<^sub>o b)\<close>
  then obtain b where x: \<open>x = id_cblinfun \<otimes>\<^sub>o b\<close>
    by auto
  then show \<open>x \<in> commutant (range (\<lambda>a. a \<otimes>\<^sub>o id_cblinfun))\<close>
    by (auto simp: x commutant_def comp_tensor_op)
qed

lemma complement_range:
  assumes [simp]: \<open>compatible F G\<close> and [simp]: \<open>iso_register (F;G)\<close>
  shows \<open>range G = commutant (range F)\<close>
proof -
  have [simp]: \<open>register F\<close> \<open>register G\<close>
    using assms compatible_def by metis+
  have [simp]: \<open>(F;G) (a \<otimes>\<^sub>o b) = F a o\<^sub>C\<^sub>L G b\<close> for a b
    using Laws_Quantum.register_pair_apply assms by blast
  have [simp]: \<open>range F = (F;G) ` range (\<lambda>a. a \<otimes>\<^sub>o id_cblinfun)\<close>
    by force
  have [simp]: \<open>range G = (F;G) ` range (\<lambda>b. id_cblinfun \<otimes>\<^sub>o b)\<close>
    by force
  show \<open>range G = commutant (range F)\<close>
    by (simp add: commutant_exchange commutant_tensor1)
qed

lemma same_range_equivalent:
  fixes F :: \<open>'a::finite update \<Rightarrow> 'c::finite update\<close> and G :: \<open>'b::finite update \<Rightarrow> 'c::finite update\<close>
  assumes [simp]: \<open>register F\<close> and [simp]: \<open>register G\<close>
  assumes \<open>range F = range G\<close>
  shows \<open>equivalent_registers F G\<close>
proof -
  have G_rangeF[simp]: \<open>G x \<in> range F\<close> for x
    by (simp add: assms)
  have F_rangeG[simp]: \<open>F x \<in> range G\<close> for x
    by (simp add: assms(3)[symmetric])
  have [simp]: \<open>inj F\<close> and [simp]: \<open>inj G\<close>
    by (simp_all add: register_inj)
  have [simp]: \<open>clinear F\<close> \<open>clinear G\<close>
    by simp_all
  define I J where \<open>I x = inv F (G x)\<close> and \<open>J y = inv G (F y)\<close> for x y
  have addI: \<open>I (x + y) = I x + I y\<close> for x y
    unfolding I_def
    apply (rule injD[OF \<open>inj F\<close>])
    apply (subst complex_vector.linear_add[OF \<open>clinear F\<close>])
    apply (subst Hilbert_Choice.f_inv_into_f[where f=F], simp)+
    by (simp add: complex_vector.linear_add)
  have addJ: \<open>J (x + y) = J x + J y\<close> for x y
    unfolding J_def
    apply (rule injD[OF \<open>inj G\<close>])
    apply (subst complex_vector.linear_add[OF \<open>clinear G\<close>])
    apply (subst Hilbert_Choice.f_inv_into_f[where f=G], simp)+
    by (simp add: complex_vector.linear_add)
  have scaleI: \<open>I (r *\<^sub>C x) = r *\<^sub>C I x\<close> for r x
    unfolding I_def
    apply (rule injD[OF \<open>inj F\<close>])
    apply (subst complex_vector.linear_scale[OF \<open>clinear F\<close>])
    apply (subst Hilbert_Choice.f_inv_into_f[where f=F], simp)+
    by (simp add: complex_vector.linear_scale)
  have scaleJ: \<open>J (r *\<^sub>C x) = r *\<^sub>C J x\<close> for r x
    unfolding J_def
    apply (rule injD[OF \<open>inj G\<close>])
    apply (subst complex_vector.linear_scale[OF \<open>clinear G\<close>])
    apply (subst Hilbert_Choice.f_inv_into_f[where f=G], simp)+
    by (simp add: complex_vector.linear_scale)
  have unitalI: \<open>I id_cblinfun = id_cblinfun\<close>
    unfolding I_def
    apply (rule injD[OF \<open>inj F\<close>])
    apply (subst Hilbert_Choice.f_inv_into_f[where f=F])
     apply auto
    by (metis register_of_id G_rangeF assms(2))
  have unitalJ: \<open>J id_cblinfun = id_cblinfun\<close>
    unfolding J_def
    apply (rule injD[OF \<open>inj G\<close>])
    apply (subst Hilbert_Choice.f_inv_into_f[where f=G])
     apply auto
    by (metis register_of_id F_rangeG assms(1))
  have multI: \<open>I (a o\<^sub>C\<^sub>L b) = I a o\<^sub>C\<^sub>L I b\<close> for a b
    unfolding I_def
    apply (rule injD[OF \<open>inj F\<close>])
    apply (subst register_mult[symmetric, OF \<open>register F\<close>])
    apply (subst Hilbert_Choice.f_inv_into_f[where f=F], simp)+
    by (simp add: register_mult)
  have multJ: \<open>J (a o\<^sub>C\<^sub>L b) = J a o\<^sub>C\<^sub>L J b\<close> for a b
    unfolding J_def
    apply (rule injD[OF \<open>inj G\<close>])
    apply (subst register_mult[symmetric, OF \<open>register G\<close>])
    apply (subst Hilbert_Choice.f_inv_into_f[where f=G], simp)+
    by (simp add: register_mult)
  have adjI: \<open>I (a*) = (I a)*\<close> for a
    unfolding I_def
    apply (rule injD[OF \<open>inj F\<close>])
    apply (subst register_adjoint[OF \<open>register F\<close>])
    apply (subst Hilbert_Choice.f_inv_into_f[where f=F], simp)+
    using assms(2) register_adjoint by blast
  have adjJ: \<open>J (a*) = (J a)*\<close> for a
    unfolding J_def
    apply (rule injD[OF \<open>inj G\<close>])
    apply (subst register_adjoint[OF \<open>register G\<close>])
    apply (subst Hilbert_Choice.f_inv_into_f[where f=G], simp)+
    using assms(1) register_adjoint by blast

  from addI scaleI unitalI multI adjI
  have \<open>register I\<close>
    unfolding register_def by (auto intro!: clinearI)
  from addJ scaleJ unitalJ multJ adjJ
  have \<open>register J\<close>
    unfolding register_def by (auto intro!: clinearI)

  have \<open>I o J = id\<close>
    unfolding I_def J_def o_def
    apply (subst Hilbert_Choice.f_inv_into_f[where f=G], simp)
    apply (subst Hilbert_Choice.inv_f_f[OF \<open>inj F\<close>])
    by auto
  have \<open>J o I = id\<close>
    unfolding I_def J_def o_def
    apply (subst Hilbert_Choice.f_inv_into_f[where f=F], simp)
    apply (subst Hilbert_Choice.inv_f_f[OF \<open>inj G\<close>])
    by auto

  from \<open>I o J = id\<close> \<open>J o I = id\<close> \<open>register I\<close> \<open>register J\<close>
  have \<open>iso_register I\<close>
    using iso_register_def by blast

  have \<open>F o I = G\<close>
    unfolding I_def o_def
    by (subst Hilbert_Choice.f_inv_into_f[where f=F], auto)

  with \<open>iso_register I\<close> show ?thesis
    unfolding equivalent_registers_def by auto
qed

lemma complement_unique:
  assumes "compatible F G" and \<open>iso_register (F;G)\<close>
  assumes "compatible F H" and \<open>iso_register (F;H)\<close>
  shows \<open>equivalent_registers G H\<close>
  by (metis assms compatible_def complement_range same_range_equivalent)

end


section {*partial\_functions*}
theory
  partial_functions

imports
  PRJ_01_02__ENTRY

begin

lemma partial_termination_wf_prime: "
  \<forall>x::'\<alpha>. RECURSIVE_COND x \<and> TERM_ARGS_TEST x \<longrightarrow> TERM_ARGS_TEST (MODIFY_ARGS_FOR_REC_CALL x)
  \<Longrightarrow> \<forall>x::'\<alpha>. RECURSIVE_COND x \<and> TERM_ARGS_TEST x \<longrightarrow> ((MEASURE::'\<alpha>\<Rightarrow>nat) x)>(MEASURE (MODIFY_ARGS_FOR_REC_CALL x))
  \<Longrightarrow> \<forall>x::'\<alpha>. (\<not>(RECURSIVE_COND x)) \<and> TERM_ARGS_TEST x \<longrightarrow> TERM_FUN x
  \<Longrightarrow> \<forall>x::'\<alpha>. TERM_FUN (MODIFY_ARGS_FOR_REC_CALL x) \<and> TERM_ARGS_TEST (MODIFY_ARGS_FOR_REC_CALL x) \<and> TERM_ARGS_TEST x \<longrightarrow> TERM_FUN x
  \<Longrightarrow> \<forall>y. x = MEASURE y \<and> TERM_ARGS_TEST y \<longrightarrow> TERM_FUN y"
  apply(rule nat_less_induct)
  apply(rename_tac n)(*strict*)
  apply(clarify)
  apply(rename_tac n y)(*strict*)
  apply(erule_tac
      x = "y"
      and P = "\<lambda>y. TERM_FUN (MODIFY_ARGS_FOR_REC_CALL y) \<and> TERM_ARGS_TEST (MODIFY_ARGS_FOR_REC_CALL y) \<and> TERM_ARGS_TEST y \<longrightarrow> TERM_FUN y"
      in allE)
  apply(rename_tac n y)(*strict*)
  apply(case_tac "RECURSIVE_COND y")
   apply(rename_tac n y)(*strict*)
   apply(subgoal_tac "TERM_FUN (MODIFY_ARGS_FOR_REC_CALL y)")
    apply(rename_tac n y)(*strict*)
    apply(rule_tac
      P = "TERM_FUN (MODIFY_ARGS_FOR_REC_CALL y) \<and> TERM_ARGS_TEST (MODIFY_ARGS_FOR_REC_CALL y) \<and> TERM_ARGS_TEST y"
      in mp)
     apply(rename_tac n y)(*strict*)
     apply(blast)
    apply(rename_tac n y)(*strict*)
    apply(clarify)
    apply(force)
   apply(rename_tac n y)(*strict*)
   defer
   apply(blast)
  apply(rename_tac n y)(*strict*)
  apply(erule_tac
      x = "MEASURE (MODIFY_ARGS_FOR_REC_CALL y)"
      in allE)
  apply(erule_tac
      P = "MEASURE (MODIFY_ARGS_FOR_REC_CALL y) < MEASURE y"
      in impE)
   apply(rename_tac n y)(*strict*)
   defer
   apply(erule_tac
      x = "MODIFY_ARGS_FOR_REC_CALL y"
      and P = "\<lambda>ya. MEASURE (MODIFY_ARGS_FOR_REC_CALL y) = MEASURE ya \<and> TERM_ARGS_TEST ya \<longrightarrow> TERM_FUN ya"
      in allE)
   apply(rename_tac n y)(*strict*)
   apply(blast)
  apply(rename_tac n y)(*strict*)
  apply(erule_tac
      x = "y"
      and P = "\<lambda>y. RECURSIVE_COND y \<and> TERM_ARGS_TEST y \<longrightarrow> MEASURE (MODIFY_ARGS_FOR_REC_CALL y) < MEASURE y"
      in allE)
  apply(rename_tac n y)(*strict*)
  apply(clarify)
  done

lemma partial_termination_wf: "
  \<forall>x. RECURSIVE_COND x \<and> TERM_ARGS_TEST x \<longrightarrow> TERM_ARGS_TEST (MODIFY_ARGS_FOR_REC_CALL x)
  \<Longrightarrow> \<forall>x. RECURSIVE_COND x \<and> TERM_ARGS_TEST x \<longrightarrow> ((MEASURE::'\<alpha>\<Rightarrow>nat) x)>(MEASURE (MODIFY_ARGS_FOR_REC_CALL x))
  \<Longrightarrow> \<forall>x. \<not>RECURSIVE_COND x \<and> TERM_ARGS_TEST x \<longrightarrow> TERM_FUN x
  \<Longrightarrow> \<forall>x. TERM_FUN (MODIFY_ARGS_FOR_REC_CALL x) \<and> TERM_ARGS_TEST (MODIFY_ARGS_FOR_REC_CALL x) \<and> TERM_ARGS_TEST x \<longrightarrow> TERM_FUN x
  \<Longrightarrow> TERM_ARGS_TEST y
  \<Longrightarrow> TERM_FUN y"
  apply(subgoal_tac "TERM_ARGS_TEST y \<longrightarrow> TERM_FUN y")
   apply(blast)
  apply(subgoal_tac "\<forall>x. \<forall>y. x = MEASURE y \<and> TERM_ARGS_TEST y \<longrightarrow> TERM_FUN y")
   apply(blast)
  apply(rule allI)
  apply(rename_tac x)(*strict*)
  apply(rule_tac
      x = "x"
      and RECURSIVE_COND = "RECURSIVE_COND"
      and MODIFY_ARGS_FOR_REC_CALL = "MODIFY_ARGS_FOR_REC_CALL"
      in partial_termination_wf_prime)
     apply(rename_tac x)(*strict*)
     apply(blast) +
  done

lemma partial_nat_less_induct_strenthen: "
  \<forall>n. (\<forall>x. valid_item_set_INPUT x \<longrightarrow> (MEASURE::'\<alpha>\<Rightarrow>nat) x < n \<longrightarrow> P x) \<longrightarrow> (\<forall>x. valid_item_set_INPUT x \<longrightarrow> MEASURE x = n \<longrightarrow> P x)
  \<Longrightarrow> \<forall>x. valid_item_set_INPUT x \<longrightarrow> P x \<longrightarrow> Q x
  \<Longrightarrow> valid_item_set_INPUT y
  \<Longrightarrow> Q y"
  apply(subgoal_tac "\<forall>n. \<forall>y. valid_item_set_INPUT y \<longrightarrow> MEASURE y = n \<longrightarrow> P y")
   apply(blast)
  apply(rule allI)
  apply(rename_tac n)(*strict*)
  apply(rule_tac
      n = "n"
      in nat_less_induct)
  apply(rename_tac n na)(*strict*)
  apply(auto)
  done

end


(* Title:      Points
   Author:     Insa Stucke (ist@informatik.uni-kiel.de)
*)

theory Relation_Algebra_Points imports "$AFP/Relation_Algebra/Relation_Algebra"
                                       "$AFP/Relation_Algebra/Relation_Algebra_Vectors"
                                       "~~/Relation_Algebra_Cardinalities/Relation_Algebra_Orders"
                                       "~~/Relation_Algebra_Cardinalities/Relation_Algebra_Tarski"
                                       "~~/Relation_Algebra_Cardinalities/Relation_Algebra_Sums"
begin

text{* Here we define the Point Axiom and assume that we deal with finite relations. *}

class relation_algebra_fin_points = relation_algebra_tarski +
  assumes finiteness:       "finite {x. is_point x}"
  and     pointaxiom [simp]:"\<Squnion> {x. is_point x} = top"

context relation_algebra_fin_points

begin

lemma compvecpoi:
  assumes "is_point p"
  shows "is_vector (x;p)"
using assms local.comp_assoc local.is_point_def local.is_vector_def by auto

lemma pointvec:
  assumes "is_point x"
  and "is_vector y"
  shows "y \<cdot> x \<le> \<Squnion>{p |p. is_point p \<and> p \<le> y}"
proof -
   have a: "x \<le> y \<or> x \<cdot> y \<le> 0"
     by (simp add: assms leq_point_vect')
   then have b: "y \<cdot> x \<le> \<Squnion>{p |p. is_point p \<and> p \<le> y}"
    proof
      assume asm: "x \<cdot> y \<le> 0"
      show "y \<cdot> x \<le> \<Squnion>{p |p. is_point p \<and> p \<le> y}"
        using asm antisym bot_least inf.commute by fastforce
    next
      assume asm: "x \<le> y"
      show "y \<cdot> x \<le> \<Squnion>{p |p. is_point p \<and> p \<le> y}"
      proof (rule leq_sum_p)
          show "finite {x. is_point x \<and> x \<le> y}"
            by (simp add: finiteness)
        next
          show "is_point (y \<cdot> x) \<and> y \<cdot> x \<le> y"
            by (simp add: asm assms(1) inf.absorb2)
        qed
    qed
 thus ?thesis
   by blast
qed

lemma pointaux:
  assumes "is_vector y"
  shows "\<Squnion> {y \<cdot> p |p. is_point p} \<le> \<Squnion> {p |p. is_point p \<and> p \<le> y}"
using lub_sum_p assms pointvec finiteness by blast

lemma pointax' [simp]:
  assumes "is_vector x"
  shows "\<Squnion> {p. is_point p \<and> p \<le> x} = x"
proof (rule antisym)
  show "\<Squnion>{p. is_point p \<and> p \<le> x} \<le> x"
    by (metis (no_types, lifting) bot_least lub_sum sum.infinite mem_Collect_eq)
next
  have "x = x \<cdot> \<Squnion> {p |p. is_point p}"
    using pointaxiom by auto
  also have "\<dots> = \<Squnion> {x \<cdot> p |p. is_point p}"
    using pointaxiom finiteness sum_cap_distr_left by blast
  also have "\<dots> \<le> \<Squnion> {p |p. is_point p \<and> p \<le> x}"
    using assms pointaux by blast
  finally show "x \<le> \<Squnion>{p. is_point p \<and> p \<le> x}"
    using Collect_cong by auto
qed

lemma point_sum_add_comp: "x; (\<Squnion>{p\<^sup>\<smile>|p. is_point p \<and> p \<le> y}) = \<Squnion>{x;p\<^sup>\<smile>|p. is_point p \<and> p \<le> y}"
by (simp add: finiteness sum_comp_distr_right_fun)

lemma sumid [simp]: "\<Squnion> {p ; p\<^sup>\<smile>|p . is_point p}=1'"
proof (rule antisym)
  have "1' = 1' \<cdot> \<Squnion>{p |p. is_point p}"
    using pointaxiom by auto
  also have "\<dots>= \<Squnion>{1' \<cdot> p |p. is_point p}"
    using finiteness sum_cap_distr_left by blast
  also have "\<dots> \<le> \<Squnion> {p ; p\<^sup>\<smile>|p . is_point p}"
    proof (rule sum_leq)
      show "finite {x. is_point x}"
        by (simp add: finiteness)
    next
      show "\<forall>x. is_point x \<longrightarrow> 1' \<cdot> x \<le> x ; x\<^sup>\<smile>"
        by (metis inf.boundedE maddux_20 meet_isor one_conv)
    qed
  finally show "1' \<le> \<Squnion>{p ; p\<^sup>\<smile> |p. is_point p}"
    by blast
next
  show "\<Squnion>{p ; p\<^sup>\<smile> |p. is_point p} \<le> 1'"
    proof (rule lub_sum)
      show "finite {p ; p\<^sup>\<smile> |p. is_point p}"
        by (simp add: finiteness)
    next
      show "\<forall>x\<in>{p ; p\<^sup>\<smile> |p. is_point p}. x \<le> 1'"
        using is_inj_def is_point_def by blast
  qed
qed

lemma finite_point_p_fun: "finite {f x| x. is_point x \<and> P x}"
by (simp add: finiteness)

lemma card_leq_im:
  assumes "finite {x. P x}"
  shows "card {f x| x.  P x} \<le> card {x|x.  P x} "
by (simp add: setcompr_eq_image assms card_image_le)

lemma finite_point_p_fun': "finite {x| x. \<exists> p. f p= x \<and> is_point p \<and> P p}"
proof -
  have a: "{x| x. \<exists> p. f p= x \<and> is_point p \<and> P p} = {f p| p. is_point p \<and> P p}"
    by metis
  have b: "card {f p| p. is_point p \<and> P p} \<le> card {p| p. is_point p \<and> P p}"
    using card_leq_im finiteness by blast
  thus ?thesis
    using a finite_point_p_fun by fastforce
qed

lemma finite_point_fun': "finite {x |x. \<exists>p. f p = x \<and> is_point p }"
proof -
  have a: "{x |x. \<exists>p. f p = x \<and> is_point p } = {f x |x. is_point x}"
    by metis
  have b: "finite  {f x |x. is_point x}"
    by (simp add: finiteness)
  thus ?thesis
    using a by auto
qed

lemma conv_sum:
  assumes "finite {x|x. P x}"
  shows "(\<Squnion> {x|x . P x })\<^sup>\<smile> = \<Squnion>({x\<^sup>\<smile>|x. P x })"
using setsum_fun_add' finiteness assms by auto

lemma pointssetcomp: "{x. \<exists> p q. p;q\<^sup>\<smile>=x \<and> is_point p \<and> is_point q} = {p;q\<^sup>\<smile>|p q. is_point p \<and> is_point q}"
by blast

lemma pointneqdisjp:
  assumes "is_point x"
  and "is_point y"
  and "x\<noteq>y"
  shows "x \<le> -y"
using assms dual_order.antisym galois_aux inf.commute is_point_def le_bot leq_point_vect' by blast

lemma pointcompbot:
  assumes "is_point x"
  and "is_point y"
  and "x\<noteq>y"
  shows "x\<^sup>\<smile>;y = 0"
by (metis assms compl_bot_eq double_compl galois_aux2 is_point_def is_vector_def schroeder_1 top_unique pointneqdisjp)

lemma pointcomptop:
  assumes "is_point x"
  and "is_point y"
  and "x=y"
  shows "x\<^sup>\<smile>;y = 1"
proof -
  have a: "y;1 \<le> x"
    using assms(2) assms(3) is_point_def is_vector_def by auto
  have b: "1;y\<^sup>\<smile> \<le> x\<^sup>\<smile>"
    using a conv_iso by fastforce
  have c: "-(x\<^sup>\<smile>);y \<le> 0"
    using b conv_galois_2 by auto
  show "x\<^sup>\<smile>;y = 1"
    using assms(2) b ss423 top_unique point_cnv_map by auto
qed

lemma compl_total:
  assumes "is_total x"
  shows "-(x;y) \<le> x;-y"
using assms ss424i by auto

lemma compl_inj:
  assumes "is_inj y"
  shows "-x;y \<le> -(x;y)"
by (metis assms conv_compl conv_contrav conv_invol conv_iso is_inj_def is_p_fun_def p_fun_compl)

lemma compl_sur:
  assumes "is_sur y"
  shows "-(x;y) \<le> -x;y"
by (metis assms compl_total conv_compl conv_contrav conv_iso sur_total)

lemma total_one': "is_total x \<Longrightarrow> top;x\<^sup>\<smile> = top"
by (metis conv_contrav conv_one total_def_var_1)

definition "is_linear x \<longleftrightarrow> x + x\<^sup>\<smile> = top"

lemma pointscompleq:
  assumes "is_point p"
  shows "-x;p = -(x;p)"
using assms compl_inj compl_sur local.antisym_conv local.is_point_def local.points_surj by blast

text{* Set of points is nonempty. *}
(*
lemma pointsnotempty: "{y . is_point y} \<noteq> {}"
using pointaxiom tarski by fastforce

lemma pointscompnotempty: "{x;y |y . is_point y} \<noteq> {}"
using pointsnotempty by blast
*)

lemma vectorcontpoint:
  assumes "is_vector v"
  and "v \<noteq> bot"
  shows "{y |y . is_point y \<and> y \<le> v} \<noteq> {}"
proof -
  have a: " \<Squnion> {p. is_point p \<and> p \<le> v} = v"
    by (simp add : assms)
  have b: "\<Squnion> {p. is_point p \<and> p \<le> v} \<noteq> bot"
    by (simp add: a assms(2))
  thus ?thesis
    by (metis (mono_tags, lifting) Collect_empty_eq sum.empty)
qed

lemma vectorparcap:
  assumes "is_vector x"
  and "is_vector y"
  and "x\<cdot>1' \<le> y\<cdot>1'"
  shows "x \<le> y"
  by (metis assms(1) assms(2) assms(3) local.inf.orderE local.inf_absorb2 local.mult_subdistr local.top_greatest local.vector_3)

end
end


(*section {* \Acl*{algebra}  *}*)
text {* \label{sec:theory-algebra} *}

(*<*)
theory Algebra_of_Temporal_Faults
imports Main
begin
(*>*)

text {*
In the following we present the algebraic laws for the \ac{algebra}.
*}
(*
notation
  inf (infixl "\<and>" 40) and
  sup (infixl "\<or>" 35) and
  bot ("\<bottom>") and
  top ("\<top>") and
  uminus ("\<not>") and
  xbefore (infixr "\<rightarrow>" 5) and
  tempo1 ("tempo\<^sub>1 _" 10) and
  tempo2 ("tempo\<^sub>2 _" 10) and
  tempo3 ("tempo\<^sub>3 _" 10) and
  tempo4 ("tempo\<^sub>4 _" 10) and
  neutral ("\<one>") and
  independent_events (infixl "\<triangleleft>\<triangleright>" 9)
*)

(*subsection {* Basic \ac{algebra} operators and $\tempo[1]{}$ *}*)

class algebra_of_temporal_faults_basic = boolean_algebra  +
  fixes neutral :: "'a"
  fixes xbefore :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
  fixes tempo1 :: "'a \<Rightarrow> bool"
  assumes xbefore_bot_1: "xbefore bot a = bot"
  assumes xbefore_bot_2: "xbefore a bot = bot"
  assumes xbefore_neutral_1: "xbefore neutral a = a"
  assumes xbefore_neutral_2: "xbefore a neutral = a"
  assumes xbefore_not_idempotent: "tempo1 a \<Longrightarrow> xbefore a a = bot"
  assumes inf_tempo1: "\<lbrakk>tempo1 a; tempo1 b\<rbrakk> \<Longrightarrow> tempo1 (inf a b)"
  assumes xbefore_not_sym:
    "\<lbrakk>tempo1 a; tempo1 b\<rbrakk> \<Longrightarrow> (xbefore a b) \<le> -(xbefore b a)"

(*subsection {* Definition of associativity of \ac{XBefore} *}*)

class algebra_of_temporal_faults_assoc = algebra_of_temporal_faults_basic +
  assumes xbefore_assoc: "xbefore (xbefore a b) c = xbefore a (xbefore b c)"

(*subsection {* Equivalences in the \ac{algebra} and properties *}*)

class algebra_of_temporal_faults_equivs = algebra_of_temporal_faults_assoc +
  fixes independent_events :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  fixes tempo2 :: "'a \<Rightarrow> bool"
  fixes tempo3 :: "'a \<Rightarrow> bool"
  fixes tempo4 :: "'a \<Rightarrow> bool"
  assumes xbefore_inf_equiv_bot:
    "\<lbrakk>tempo1 a; tempo1 b\<rbrakk> \<Longrightarrow> inf (xbefore a b) (xbefore b a) = bot"
  assumes xbefore_sup_equiv_inf:
    "independent_events a b \<Longrightarrow> \<lbrakk>tempo1 a; tempo1 b\<rbrakk> \<Longrightarrow>
    \<lbrakk>tempo2 a; tempo2 b\<rbrakk> \<Longrightarrow> \<lbrakk>tempo3 a; tempo3 b\<rbrakk> \<Longrightarrow> \<lbrakk>tempo4 a; tempo4 b\<rbrakk> \<Longrightarrow>
    sup (xbefore a b) (xbefore b a) = inf a b"
  assumes sup_tempo2: "\<lbrakk>tempo2 a; tempo2 b\<rbrakk> \<Longrightarrow> tempo2 (sup a b)"
  assumes inf_tempo3: "\<lbrakk>tempo3 a; tempo3 b\<rbrakk> \<Longrightarrow> tempo3 (inf a b)"
  assumes sup_tempo4: "\<lbrakk>tempo4 a; tempo4 b\<rbrakk> \<Longrightarrow> tempo4 (sup a b)"

definition tempo :: "'a::algebra_of_temporal_faults_equivs  \<Rightarrow> bool" where
"tempo a \<equiv> tempo1 a \<and> tempo2 a \<and> tempo3 a \<and> tempo4 a"

(*subsection {* \Ac{XBefore} transitivity *}*)

class algebra_of_temporal_faults_trans = algebra_of_temporal_faults_equivs +
  assumes xbefore_trans:
    "\<lbrakk>tempo1 a; tempo1 b\<rbrakk> \<Longrightarrow> tempo2 a \<Longrightarrow>
    less_eq (inf (xbefore a b) (xbefore b c)) (xbefore a c)"
  assumes inf_xbefore_trans: "\<lbrakk> tempo1 b; tempo3 b \<rbrakk> \<Longrightarrow>
    inf (xbefore a b) (xbefore b c) = xbefore (xbefore a b) c"

(*subsection {* Mixed operators in \ac{algebra} *}*)

class algebra_of_temporal_faults_mixed_ops = algebra_of_temporal_faults_trans +
  assumes xbefore_sup_1:
    "xbefore (sup a b) c = sup (xbefore a c) (xbefore b c)"
  assumes xbefore_sup_2:
    "xbefore a (sup b c) = sup (xbefore a b) (xbefore a c)"
  assumes inf_xbefore_inf_1:
    "\<lbrakk>tempo1 a; tempo1 b; tempo2 a; tempo2 b\<rbrakk> \<Longrightarrow>
      xbefore (inf a b) c = inf (xbefore a c) (xbefore b c)"
  assumes inf_xbefore_inf_2:
    "\<lbrakk>tempo1 b; tempo1 c; tempo2 b; tempo2 c\<rbrakk> \<Longrightarrow>
      xbefore a (inf b c) = inf (xbefore a b) (xbefore a c)"
  assumes not_xbefore: "
    independent_events a b \<Longrightarrow>
    \<lbrakk>tempo1 a; tempo1 b\<rbrakk> \<Longrightarrow>
    \<lbrakk>tempo2 a; tempo2 b\<rbrakk> \<Longrightarrow>
    \<lbrakk>tempo3 a; tempo3 b\<rbrakk> \<Longrightarrow>
    \<lbrakk>tempo4 a; tempo4 b\<rbrakk> \<Longrightarrow>
    - (xbefore a b) = sup (sup (- a) (- b)) (xbefore b a)"
  assumes inf_xbefore_equiv_sups_xbefore: "tempo2 a \<Longrightarrow>
    inf a (xbefore b c) = sup (xbefore (inf a b) c) (xbefore b (inf a c))"
  assumes not_1_xbefore_equiv: "\<lbrakk>tempo1 a; tempo2 b \<rbrakk> \<Longrightarrow> xbefore (- a) b = b"
  assumes not_2_xbefore_equiv: "\<lbrakk>tempo1 b; tempo2 a \<rbrakk> \<Longrightarrow> xbefore a (- b) = a"

(*subsection {* The Algebra of Temporal Faults *}*)

class algebra_of_temporal_faults = algebra_of_temporal_faults_mixed_ops

(*subsection {* Theorems in the context of \ac{algebra} *}*)

text {*
The following theorems are valid for \ac{algebra}.
They are valid for any instantiation of the \ac{algebra} class as, for example, for the sets of distinct lists type.
*}

context algebra_of_temporal_faults
begin

text {* The following theorem proves \cref{thm:xbefore-inf-1}. *}
theorem xbefore_inf_1:
  "independent_events a b \<Longrightarrow> \<lbrakk>tempo1 a; tempo1 b\<rbrakk> \<Longrightarrow>
  \<lbrakk>tempo2 a; tempo2 b\<rbrakk> \<Longrightarrow> \<lbrakk>tempo3 a; tempo3 b\<rbrakk> \<Longrightarrow> \<lbrakk>tempo4 a; tempo4 b\<rbrakk> \<Longrightarrow>
  xbefore (inf a b) c =
    sup (xbefore (xbefore a b) c) (xbefore (xbefore b a) c)"
proof-
  assume "independent_events a b" "tempo1 a" "tempo1 b"
  "tempo2 a" "tempo2 b" "tempo3 a" "tempo3 b" "tempo4 a" "tempo4 b"
  hence "xbefore (inf a b) c = xbefore (sup (xbefore a b) (xbefore b a)) c"
    by (simp add: xbefore_sup_equiv_inf)
  thus ?thesis by (simp add: xbefore_sup_1)
qed

text {* The following theorem proves \cref{thm:xbefore-inf-2}. *}
theorem xbefore_inf_2:
  "independent_events b c \<Longrightarrow> \<lbrakk>tempo1 b; tempo1 c\<rbrakk> \<Longrightarrow>
  \<lbrakk>tempo2 b; tempo2 c\<rbrakk> \<Longrightarrow> \<lbrakk>tempo3 b; tempo3 c\<rbrakk> \<Longrightarrow> \<lbrakk>tempo4 b; tempo4 c\<rbrakk> \<Longrightarrow>
  xbefore a (inf b c) =
    sup (xbefore a (xbefore b c)) (xbefore a (xbefore c b))"
proof-
  assume "independent_events b c" "tempo1 b" "tempo1 c" "tempo2 b" "tempo2 c"
  "tempo3 b" "tempo3 c" "tempo4 b" "tempo4 c"
  hence "xbefore a (inf b c) = xbefore a (sup (xbefore b c) (xbefore c b))"
    by (simp add: xbefore_sup_equiv_inf)
  thus ?thesis by (simp add: xbefore_sup_2)
qed

text {* The following lemma proves \cref{thm:xbefore-sup-absorb-2}. *}
lemma xbefore_sup_absorb_1b:
  "independent_events a b \<Longrightarrow> \<lbrakk>tempo1 a; tempo1 b\<rbrakk> \<Longrightarrow>
    \<lbrakk>tempo2 a; tempo2 b\<rbrakk> \<Longrightarrow> \<lbrakk>tempo3 a; tempo3 b\<rbrakk> \<Longrightarrow> \<lbrakk>tempo4 a; tempo4 b\<rbrakk> \<Longrightarrow>
    sup (xbefore b a) a = a"
by (metis inf_le1 order_trans sup.absorb2 sup.cobounded2
  xbefore_sup_equiv_inf)

lemma xbefore_sup_absorb_2:
  "independent_events a b \<Longrightarrow> \<lbrakk>tempo1 a; tempo1 b\<rbrakk> \<Longrightarrow>
    \<lbrakk>tempo2 a; tempo2 b\<rbrakk> \<Longrightarrow> \<lbrakk>tempo3 a; tempo3 b\<rbrakk> \<Longrightarrow> \<lbrakk>tempo4 a; tempo4 b\<rbrakk> \<Longrightarrow>
    sup a (xbefore a b) = a"
by (metis dual_order.trans inf.cobounded1 sup.absorb1 sup.cobounded1
  xbefore_sup_equiv_inf)

text {* The following corollary proves \cref{thm:xbefore-sup-absorb-1}. *}
corollary xbefore_sup_absorb_1:
  "independent_events a b \<Longrightarrow> \<lbrakk>tempo1 a; tempo1 b\<rbrakk> \<Longrightarrow>
    \<lbrakk>tempo2 a; tempo2 b\<rbrakk> \<Longrightarrow> \<lbrakk>tempo3 a; tempo3 b\<rbrakk> \<Longrightarrow> \<lbrakk>tempo4 a; tempo4 b\<rbrakk> \<Longrightarrow>
    sup (xbefore a b) a = a"
proof-
  assume 0: "independent_events a b" "tempo1 a" "tempo1 b" "tempo2 a"
  "tempo2 b" "tempo3 a" "tempo3 b" "tempo4 a" "tempo4 b"
  hence "sup a (xbefore a b) = sup (xbefore a b) a"
    by (simp add: sup.commute)
  thus ?thesis using 0 by (simp add: xbefore_sup_absorb_2)
qed

corollary xbefore_sup_absorb_2b:
  "independent_events a b \<Longrightarrow> \<lbrakk>tempo1 a; tempo1 b\<rbrakk> \<Longrightarrow>
    \<lbrakk>tempo2 a; tempo2 b\<rbrakk> \<Longrightarrow> \<lbrakk>tempo3 a; tempo3 b\<rbrakk> \<Longrightarrow> \<lbrakk>tempo4 a; tempo4 b\<rbrakk> \<Longrightarrow>
    sup a (xbefore b a) = a"
proof-
  assume 0: "independent_events a b" "tempo1 a" "tempo1 b" "tempo2 a"
  "tempo2 b" "tempo3 a" "tempo3 b" "tempo4 a" "tempo4 b"
  hence "sup a (xbefore b a) = sup (xbefore b a) a"
    by (simp add: sup.commute)
  thus ?thesis using 0 by (simp add: xbefore_sup_absorb_1b)
qed

text {* The following corollary proves \cref{thm:xbefore_inf_absorb_1}. *}
theorem xbefore_inf_absorb_1: "independent_events a b \<Longrightarrow>
  \<lbrakk> tempo1 a; tempo1 b \<rbrakk> \<Longrightarrow>
  \<lbrakk> tempo2 a; tempo2 b \<rbrakk> \<Longrightarrow>
  \<lbrakk> tempo3 a; tempo3 b \<rbrakk> \<Longrightarrow>
  \<lbrakk> tempo4 a; tempo4 b \<rbrakk> \<Longrightarrow>
  inf a (xbefore a b) = xbefore a b"
by (simp add: local.inf_absorb2 local.le_iff_sup xbefore_sup_absorb_1)

text {* The following corollary proves \cref{thm:xbefore_inf_absorb_2}. *}
theorem xbefore_inf_absorb_2: "independent_events a b \<Longrightarrow>
  \<lbrakk> tempo1 a; tempo1 b \<rbrakk> \<Longrightarrow>
  \<lbrakk> tempo2 a; tempo2 b \<rbrakk> \<Longrightarrow>
  \<lbrakk> tempo3 a; tempo3 b \<rbrakk> \<Longrightarrow>
  \<lbrakk> tempo4 a; tempo4 b \<rbrakk> \<Longrightarrow>
  inf a (xbefore b a) = xbefore b a"
by (simp add: local.inf.absorb2 local.sup.absorb_iff1 xbefore_sup_absorb_2b)

text {* The following lemma proves \cref{thm:and_xbefore_equiv_or_xbefore_expanded}. *}
lemma inf_xbefore_equiv_sups_xbefore_expanded:
  "independent_events a b \<Longrightarrow> independent_events a c \<Longrightarrow>
  \<lbrakk>tempo1 a; tempo1 b; tempo1 c\<rbrakk> \<Longrightarrow> \<lbrakk>tempo2 a; tempo2 b; tempo2 c\<rbrakk> \<Longrightarrow>
  \<lbrakk>tempo3 a; tempo3 b; tempo3 c\<rbrakk> \<Longrightarrow> \<lbrakk>tempo4 a; tempo4 b; tempo4 c\<rbrakk> \<Longrightarrow>
    inf a (xbefore b c) =
    sup (sup (xbefore (xbefore a b) c)
      (xbefore (xbefore b a) c))
      (xbefore (xbefore b c) a)"
proof-
  assume "independent_events a b" "independent_events a c"
    "tempo1 a" "tempo1 b" "tempo1 c"
    "tempo2 a" "tempo2 b" "tempo2 c"
    "tempo3 a" "tempo3 b" "tempo3 c"
    "tempo4 a" "tempo4 b" "tempo4 c"
  hence "inf a (xbefore b c) =
    sup (xbefore (inf a b) c) (xbefore b (inf a c))"
    "xbefore (inf a b) c =
    sup (xbefore (xbefore a b) c) (xbefore (xbefore b a) c)"
    "xbefore b (inf a c) =
    sup (xbefore (xbefore b a) c) (xbefore (xbefore b c) a)"
    by (auto simp add: inf_xbefore_equiv_sups_xbefore xbefore_inf_1
      xbefore_inf_2 xbefore_assoc)
  thus ?thesis by (simp add: sup.assoc)
qed

text {* The following lemma proves \cref{thm:xbefore_sup_compl_inf_absorb1}. *}
lemma xbefore_sup_compl_inf_absorb1:
  "independent_events a b \<Longrightarrow> \<lbrakk>tempo1 a; tempo1 b\<rbrakk> \<Longrightarrow>
    \<lbrakk>tempo2 a; tempo2 b\<rbrakk> \<Longrightarrow> \<lbrakk>tempo3 a; tempo3 b\<rbrakk> \<Longrightarrow> \<lbrakk>tempo4 a; tempo4 b\<rbrakk> \<Longrightarrow>
    sup (inf a (-b)) (xbefore a b) = inf a (- (xbefore b a))"
proof -
  assume a1: "independent_events a b"
  assume a2: "tempo1 a"
  assume a3: "tempo1 b"
  assume a4: "tempo2 a"
  assume a5: "tempo2 b"
  assume a6: "tempo3 a"
  assume a7: "tempo3 b"
  assume a8: "tempo4 a"
  assume a9: "tempo4 b"
  then have f10: "- xbefore a b = sup (sup (- a) (- b)) (xbefore b a)"
    using a8 a7 a6 a5 a4 a3 a2 a1 by (meson local.not_xbefore)
  have f11: "\<forall>a aa ab. inf (a::'a) (sup aa ab) = sup (inf a aa) (inf a ab)"
    using local.distrib_imp2 local.sup_inf_distrib1 by force
  then have f12: "sup bot (xbefore b a) = inf b (sup (- b) (xbefore b a))"
    using a7 a3 by (metis local.inf_compl_bot local.inf_xbefore_trans local.xbefore_neutral_1)
  have f13: "inf (sup (- a) (- (- b))) (sup (- a) (- b)) = sup (- a) (inf b (- b))"
    using local.double_compl local.sup_inf_distrib1 by presburger
  have f14: "inf a (xbefore b a) = xbefore b a"
    using a9 a8 a7 a6 a5 a4 a3 a2 a1 by (meson xbefore_inf_absorb_2)
  have f15: "sup (sup (inf (sup (- a) (- b)) (- a)) (inf (xbefore b a) (- a))) bot = sup (- a) (inf b (- b))"
    using f10 a9 a8 a7 a6 a5 a4 a3 a2 a1 by (metis (no_types) local.compl_sup local.inf_compl_bot local.inf_sup_distrib2 xbefore_sup_absorb_1)
  have "inf a (- a) = sup (inf (xbefore b a) (- a)) bot"
    using f14 f11 by (metis (no_types) local.compl_inf local.inf_compl_bot)
  then have "sup (- sup (- a) (- (- b))) (- sup (- a) (- b)) = - inf (sup (sup (- a) (- b)) a) (- a)"
    using f15 f13 by (metis (full_types) local.compl_inf local.inf_sup_distrib2 local.sup_assoc)
  then have "sup (- sup (- a) (- (- b))) (- sup (- a) (- b)) = a"
    by (simp add: local.sup_assoc)
  then show ?thesis
    using f13 f12 f10 by (metis (no_types) local.compl_inf local.compl_sup local.double_compl local.inf_compl_bot local.sup_assoc local.sup_inf_distrib1)
qed

corollary xbefore_sup_equiv_inf_inf_nand:
  "tempo a \<Longrightarrow> tempo b \<Longrightarrow> independent_events a b \<Longrightarrow>
  sup (sup (xbefore a b) (xbefore b a)) (- (inf a b)) = top"
unfolding tempo_def
by (metis (mono_tags, lifting) boolean_algebra_class.sup_compl_top algebra_of_temporal_faults_equivs_class.xbefore_sup_equiv_inf)

end

end
(*>*)


theory Code_Target_Rational
  imports Code_Rational "HOL-Library.Code_Target_Int"
begin

code_datatype rat_of_rational

declare [[code drop: rational_of_rat]]

lemma numeral_rat_of_rational [code_unfold]:
  "(numeral x :: rat) = rat_of_rational (numeral x)"
  by (transfer, simp)

lemma rat_of_int_int_of_integer [code_unfold]:
  "Rat.of_int (int_of_integer x) = rat_of_rational (rational_of_integer x)"
  unfolding rational_of_integer_def
  by (simp add: Frct_integer.rep_eq Rat.of_int_def of_int_rat)

lemma plus_rat_of_rational [code]:
  "(rat_of_rational x) + (rat_of_rational y) = rat_of_rational (x + y)"
  by (transfer, simp)

lemma uminus_rat_of_rational [code]:
  "- (rat_of_rational x) = rat_of_rational (- x)"
  by (transfer, simp)

lemma minus_rat_of_rational [code]:
  "(rat_of_rational x) - (rat_of_rational y) = rat_of_rational (x - y)"
  by (transfer, simp)

lemma times_rat_of_rational [code]:
  "(rat_of_rational x) * (rat_of_rational y) = rat_of_rational (x * y)"
  by (transfer, simp)

lemma divide_rat_of_rational [code]:
  "(rat_of_rational x) / (rat_of_rational y) = rat_of_rational (x / y)"
  by (transfer, simp)

lemma [code]: "1 = rat_of_rational 1"
  by simp

lemma rat_of_rational_power: "rat_of_rational x ^ n = rat_of_rational (x ^ n)"
  by (induct n, simp_all)

lemma [code_unfold]: "power (rat_of_rational x) (nat_of_integer y)
       = rat_of_rational (integer_power x y)"
  by (simp add: integer_power_def rat_of_rational_power)

lemma [code]: "quotient_of (rat_of_rational x) = (int_of_integer (numerator x), int_of_integer (denominator x))"
  by (simp add: denominator_def numerator_def)

(*
definition vel :: "real \<Rightarrow> real" where
"vel t = 10 * t^2 + 8"

definition "myrat = (7.896 :: rat)"

export_code myrat vel in Haskell
*)

end


section {* Addition with fixpoint of successor *}

theory Ex3
imports "../LCF"
begin

axiomatization
  s     :: "'a \<Rightarrow> 'a" and
  p     :: "'a \<Rightarrow> 'a \<Rightarrow> 'a"
where
  p_strict:     "p(UU) = UU" and
  p_s:          "p(s(x),y) = s(p(x,y))"

declare p_strict [simp] p_s [simp]

lemma example: "p(FIX(s),y) = FIX(s)"
  apply (induct s)
  apply simp
  apply simp
  done

end


(*<*)
theory Finite_Proof_Soundness
imports Abstract_Completeness.Abstract_Completeness
begin
(*>*)

section \<open>Abstract Soundness\<close>

locale Soundness = RuleSystem_Defs eff rules for
  eff :: "'rule \<Rightarrow> 'sequent \<Rightarrow> 'sequent fset \<Rightarrow> bool"
  and rules :: "'rule stream" +
  fixes "structure" :: "'structure set"
    and sat :: "'structure \<Rightarrow> 'sequent \<Rightarrow> bool"
  assumes local_soundness:
    "\<And>r s sl.
      \<lbrakk>r \<in> R; eff r s sl; \<And>s'. s' |\<in>| sl \<Longrightarrow> \<forall>S \<in> structure. sat S s'\<rbrakk>
      \<Longrightarrow>
      \<forall>S \<in> structure. sat S s"
begin

abbreviation "ssat s \<equiv> \<forall>S \<in> structure. sat S s"

lemma epath_shift:
  assumes "epath (srs @- steps)"
  shows "epath steps"
  using assms by (induction srs arbitrary: steps) (auto elim: epath.cases)

theorem soundness:
  assumes f: "tfinite t" and w: "wf t"
  shows "ssat (fst (root t))"
  using f w proof (induction t rule: tfinite.induct)
  case (tfinite t)
  show ?case
    by (rule local_soundness[of "snd (root t)" _ "fimage (fst o root) (cont t)"], insert tfinite)
      (fastforce elim!: wf.cases)+
qed

end (* context Soundness *)

(*<*)
end
(*>*)


theory WellTypedAlt
  imports WTLemma
begin

datatype wta_tag =
  ConstRule
  | OpRule
  | VarRule
  | PairRule
  | IfRule
  | LamRule
  | AppRule
  | WeakPostRule wta_tag
  | StrReqRule wta_tag
  | WeakReqRule wta_tag

fun well_typed_alt :: "wta_tag \<Rightarrow> pt_env \<Rightarrow> perm_use_env \<Rightarrow> p_exp \<Rightarrow> p_type \<Rightarrow> perm_use_env \<Rightarrow> perm_use_env \<Rightarrow> bool" where
  "well_typed_alt ConstRule env r_s1 e tau r_s2 rx = (\<exists> c. e = ConstExp c \<and> tau \<in> const_type c \<and> r_s2 = r_s1 \<and> rx = empty_use_env)"
| "well_typed_alt OpRule env r_s1 e tau r_s2 rx = (\<exists> xop. e = OpExp xop \<and> tau = op_type xop \<and> r_s2 = r_s1 \<and> rx = empty_use_env)"
| "well_typed_alt VarRule env r_s1 e tau r_s2 rx = (\<exists> v tau_x. e = VarExp v \<and> env (res_name v) = Some tau \<and>
    env (owner_name v) = Some tau_x \<and> value_req v tau tau_x \<and> leq_use_env (ereq_use_env (owner_name v) tau_x) r_s1 \<and> r_s2 = diff_use_env r_s1 (ereq_use_env (owner_name v) tau_x) \<and>
    rx = diff_use_env (ereq_use_env (owner_name v) tau_x) (ereq_use_env (owner_name v) tau_x))"
| "well_typed_alt PairRule env r_s1 e tau r_s3 rf = (\<exists> e1 e2 t1 t2 r r_s2 rx1 rx2. e = PairExp e1 e2 \<and>
    tau = PairTy t1 t2 r \<and> well_typed env r_s1 e1 t1 r_s2 rx1 \<and> well_typed env r_s2 e2 t2 r_s3 rx2 \<and>
    leq_use_env (lift_use_env rx1 r) r_s3 \<and> leq_use_env (lift_use_env rx2 r) r_s3 \<and> aff_leq (max_aff (req_type t1) (req_type t2)) r \<and>
    disj_use_env (lift_use_env rx1 r) (lift_use_env rx2 r) \<and>
    rf = pair_req (comp_use_env (lift_use_env rx1 r) (lift_use_env rx2 r)) empty_use_env tau
  )"
| "well_typed_alt IfRule env r_s1 e tau r_s3 rx = (\<exists> e1 e2 e3 rx' r_s2 rx1 rx2. e = IfExp e1 e2 e3 \<and>
    well_typed env r_s1 e1 BoolTy r_s2 rx' \<and> well_typed env r_s2 e2 tau r_s3 rx1 \<and> well_typed env r_s2 e3 tau r_s3 rx2 \<and>
    rx = comp_use_env rx1 rx2)"
| "well_typed_alt LamRule env r_s1 ex tau r_s2 rx = (\<exists> x e t1 t2 r a r_end r_s'. ex = LamExp x e \<and>
    tau = FunTy t1 t2 r a \<and>
    well_typed (add_env env (Var x) t1) (add_use_env rx (Var x) r) e t2 r_s' r_end \<and> aff_use_env rx a \<and>
    leq_use_env rx r_s1 \<and> r_s2 = r_s1)"
| "well_typed_alt AppRule env r_s1 e tau r_sf rx = (\<exists> e1 e2 t1 r a r_s2 rx1 rx2 r_s3. e = AppExp e1 e2 \<and>
    well_typed env r_s1 e1 (FunTy t1 tau r a) r_s2 rx1 \<and> well_typed env r_s2 e2 t1 r_s3 rx2 \<and>
    r_sf = diff_use_env r_s3 (comp_use_env rx1 (lift_use_env rx2 r)) \<and> (*r \<noteq> NoPerm \<and>*) (*safe_use_lift rx2 r \<and>
    safe_type t1 r \<and>*) leq_use_env (comp_use_env rx1 (lift_use_env rx2 r)) r_s3 \<and>
    disj_use_env rx1 (lift_use_env rx2 r) \<and> leq_use_env rx r_sf \<and>
    rx = app_req rx1 rx2 r tau empty_use_env
  )"
| "well_typed_alt (WeakPostRule tag) env r_s1 e tau r_s2 rx = (\<exists> r_c. well_typed_alt tag env r_s1 e tau r_c rx \<and>
    leq_use_env rx r_s2 \<and> leq_use_env r_s2 r_c)"
| "well_typed_alt (StrReqRule tag) env r_s1 e tau r_s2 rx = (\<exists> rx'. well_typed_alt tag env r_s1 e tau r_s2 rx' \<and>
    leq_use_env rx' rx \<and> leq_use_env rx r_s2)"
| "well_typed_alt (WeakReqRule tag) env r_s1 e tau r_s2 rx = (\<exists> r_se r_xe r_ex. well_typed_alt tag env r_s1 e tau r_se r_xe \<and>
    r_s2 = diff_use_env r_se r_ex \<and> rx = diff_use_env r_xe r_ex \<and> leq_use_env r_ex r_s1)"

lemma well_typed_equiv1: "\<lbrakk> well_typed env r_s1 e tau r_s2 rx \<rbrakk> \<Longrightarrow> (\<exists> tag. well_typed_alt tag env r_s1 e tau r_s2 rx)"
  apply (induct e arbitrary: env r_s1 r_s2 tau rx)
        apply (auto)
    (* const case *)
        apply (rule_tac x="StrReqRule (WeakPostRule ConstRule)" in exI)
        apply (auto)
         apply (rule_tac leq_empty_use_env)
        apply (rule_tac leq_empty_use_env)
    (* op case *)
       apply (rule_tac x="StrReqRule (WeakPostRule OpRule)" in exI)
       apply (auto)
        apply (rule_tac leq_empty_use_env)
       apply (rule_tac leq_empty_use_env)
    (* var case *)
      apply (rule_tac x="WeakPostRule (StrReqRule (WeakReqRule VarRule))" in exI)
      apply (auto)
      apply (rule_tac x="diff_use_env (diff_use_env r_s1 (ereq_use_env (owner_name x) tau_x)) r_ex" in exI)
      apply (auto)
       apply (rule_tac x="diff_use_env (diff_use_env (ereq_use_env (owner_name x) tau_x) (ereq_use_env (owner_name x) tau_x)) r_ex" in exI)
       apply (auto)
        apply (rule_tac lhs_fold_dcl_use_env)
        apply (simp)
       apply (rule_tac r_sb="r_s2" in trans_leq_use_env)
        apply (rule_tac rhs_fold_dcl_use_env)
        apply (simp_all)
      apply (rule_tac rhs_fold_dcl_use_env)
      apply (simp)
    (* pair case *)
     apply (rule_tac x="WeakPostRule (StrReqRule (WeakReqRule PairRule))" in exI)
     apply (auto)
     apply (rule_tac x="diff_use_env r_s3 r_ex" in exI)
     apply (auto)
     apply (rule_tac x="pair_req (comp_use_env (lift_use_env rx1 r) (lift_use_env rx2 r)) r_ex (PairTy t1 t2 r)" in exI)
     apply (auto)
      apply (rule_tac x="r_s3" in exI)
      apply (rule_tac x="pair_req (comp_use_env (lift_use_env rx1 r) (lift_use_env rx2 r)) empty_use_env (PairTy t1 t2 r)" in exI)
      apply (auto)
      apply (rule_tac x="r_ex" in exI)
      apply (auto)
      apply (simp add: pair_req_def)
      apply (auto)
       apply (simp add: diff_empty_use_env1)
      apply (simp add: diff_empty_use_env2)
     apply (rule_tac r_sb="r_s2" in trans_leq_use_env)
      apply (auto)
    (* if case *)
    apply (rule_tac x="IfRule" in exI)
    apply (auto)
    (* lam case *)
   apply (rule_tac x="WeakPostRule (StrReqRule (WeakReqRule LamRule))" in exI)
   apply (auto)
   apply (rule_tac x="diff_use_env r_s1 r_ex" in exI)
   apply (auto)
   apply (rule_tac x="diff_use_env rxa r_ex" in exI)
   apply (auto)
   apply (rule_tac r_sb="r_s2" in trans_leq_use_env)
    apply (auto)
    (* app case *)
  apply (rule_tac x="WeakPostRule (StrReqRule (WeakReqRule AppRule))" in exI)
  apply (auto)
  apply (rule_tac x="diff_use_env (diff_use_env r_s3 (comp_use_env rx1 (lift_use_env rx2 r))) r_ex" in exI)
  apply (auto)
   apply (rule_tac x="app_req rx1 rx2 r tau r_ex" in exI)
   apply (auto)
    apply (rule_tac x="diff_use_env r_s3 (comp_use_env rx1 (lift_use_env rx2 r))" in exI)
    apply (rule_tac x="app_req rx1 rx2 r tau empty_use_env" in exI)
    apply (auto)
     apply (rule_tac x="t1" in exI)
     apply (rule_tac x="r" in exI)
     apply (rule_tac x="a" in exI)
     apply (rule_tac x="r_s2a" in exI)
     apply (rule_tac x="rx1" in exI)
     apply (auto)
     apply (rule_tac x="rx2" in exI)
     apply (rule_tac x="r_s3" in exI)
     apply (auto)
     apply (simp add: app_req_def)
     apply (auto)
      apply (rule_tac leq_empty_use_env)
     apply (rule_tac dist_diff_leq_use_env_gen)
      apply (rule_tac r_sb="comp_use_env rx1 (lift_use_env rx2 r)" in trans_leq_use_env)
       apply (simp)
      apply (rule_tac dist_comp_leq_use_env)
       apply (rule_tac self_comp_leq_use_env1)
      apply (rule_tac comp_leq_use_env2)
      apply (rule_tac self_lift_leq_use_env)
     apply (rule_tac self_comp_leq_use_env1)
    apply (rule_tac x="r_ex" in exI)
    apply (auto)
    apply (simp add: app_req_def)
    apply (auto)
     apply (simp add: diff_empty_use_env1)
    apply (simp add: comp_empty_use_env2)
    apply (simp add: diff_comp_use_env)
   apply (rule_tac r_sb="r_s2" in trans_leq_use_env)
    apply (rule_tac rhs_fold_dcl_use_env)
    apply (simp_all)
  apply (rule_tac rhs_fold_dcl_use_env)
  apply (simp)
  done

lemma well_typed_equiv2: "\<lbrakk> well_typed_alt tag env r_s1 e tau r_s2 rx \<rbrakk> \<Longrightarrow> well_typed env r_s1 e tau r_s2 rx"
  apply (induct tag arbitrary: env r_s1 e tau r_s2 rx)
           apply (auto)
    (* const + op case *)
             apply (rule_tac id_leq_use_env)
            apply (rule_tac leq_empty_use_env)
           apply (rule_tac id_leq_use_env)
          apply (rule_tac leq_empty_use_env)
    (* var case *)
         apply (rule_tac x="empty_use_env" in exI)
         apply (auto)
           apply (rule_tac dist_diff_leq_use_env_gen)
            apply (rule_tac id_leq_use_env)
           apply (rule_tac dist_comp_leq_use_env)
            apply (rule_tac id_leq_use_env)
           apply (rule_tac leq_empty_use_env)
          apply (rule_tac dist_diff_leq_use_env_gen)
           apply (simp)
          apply (rule_tac id_leq_use_env)
         apply (rule_tac leq_empty_use_env)
        apply (rule_tac dist_diff_leq_use_env_gen)
         apply (rule_tac id_leq_use_env)
        apply (rule_tac self_comp_leq_use_env1)
    (* pair case *)
       apply (rule_tac x="r_s2a" in exI)
       apply (rule_tac x="r_s2" in exI)
       apply (rule_tac x="rx1" in exI)
       apply (auto)
       apply (rule_tac x="rx2" in exI)
       apply (auto)
       apply (rule_tac x="empty_use_env" in exI)
       apply (auto)
          apply (simp add: diff_empty_use_env2)
          apply (rule_tac id_leq_use_env)
         apply (simp add: pair_req_def)
         apply (auto)
          apply (rule_tac leq_empty_use_env)
         apply (rule_tac diff_leq_use_env)
         apply (rule_tac dist_comp_leq_use_env)
          apply (simp_all)
        apply (rule_tac leq_empty_use_env)
       apply (simp add: pair_req_def)
       apply (auto)
        apply (rule_tac leq_empty_use_env)
       apply (rule_tac id_leq_use_env)
    (* lam case *)
      apply (rule_tac x="rx" in exI)
      apply (auto)
      apply (rule_tac x="empty_use_env" in exI)
      apply (auto)
         apply (simp add: diff_empty_use_env2)
         apply (rule_tac id_leq_use_env)
       apply (rule_tac leq_empty_use_env)
      apply (rule_tac self_diff_leq_use_env)
    (* app case *)
     apply (rule_tac x="t1" in exI)
     apply (rule_tac x="r" in exI)
     apply (rule_tac x="a" in exI)
     apply (rule_tac x="r_s2a" in exI)
     apply (rule_tac x="rx1" in exI)
     apply (auto)
     apply (rule_tac x="rx2" in exI)
     apply (rule_tac x="r_s3" in exI)
     apply (auto)
     apply (rule_tac x="empty_use_env" in exI)
     apply (auto)
       apply (rule_tac dist_diff_leq_use_env_gen)
        apply (rule_tac id_leq_use_env)
       apply (rule_tac dist_comp_leq_use_env)
        apply (rule_tac id_leq_use_env)
       apply (rule_tac leq_empty_use_env)
      apply (rule_tac leq_empty_use_env)
     apply (rule_tac id_leq_use_env)
    (* post weakening case *)
    apply (rule_tac r_c="r_c" in well_typed_decr_end_perm)
      apply (auto)
    (* req strengthening case *)
   apply (rule_tac rx="rx'" in well_typed_incr_req)
     apply (auto)
    (* req weakening case *)
  apply (rule_tac well_typed_diff_end_perm)
   apply (auto)
  done

end


theory Lmap_lappend
  imports Main "$HIPSTER_HOME/IsaHipster"
    "Lappend"
    "Lmap"

begin
setup Tactic_Data.set_coinduct_sledgehammer
setup Misc_Data.set_noisy

(* cohipster lmap lappend *)
(* Discovers and proves the following in ca. 80 seconds *)
lemma lemma_af [thy_expl]: "ltl (lappend z (lmap y z)) = lappend (ltl z) (lmap y z)"
  by (coinduction arbitrary: y z rule: Llist.Llist.coinduct_strong)
  (metis Lappend.lemma_a lappend.simps(4) lmap.ctr(1))

lemma lemma_ag [thy_expl]: "ltl (lappend (lmap y z) z) = lappend (lmap y (ltl z)) z"
  by (coinduction arbitrary: y z rule: Llist.Llist.coinduct_strong)
    (smt Llist.sel(2) Lmap.lemma_ab lappend.disc_iff(1) lappend.simps(4) lmap.disc_iff(2) lnull_def)

lemma lemma_ah [thy_expl]: "ltl (lappend (lmap y z) (ltl z)) = lappend (lmap y (ltl z)) (ltl z)"
  by (coinduction arbitrary: y z rule: Llist.Llist.coinduct_strong)
    (smt Llist.sel(2) Lmap.lemma_ab lappend.ctr(1) lappend.simps(4) lmap.disc_iff(2) lnull_def)
(* lmap distributes over lappend *)
lemma lemma_ai [thy_expl]: "lappend (lmap y z) (lmap y x2) = lmap y (lappend z x2)"
  by (coinduction arbitrary: x2 y z rule: Llist.Llist.coinduct_strong)
    (smt Llist.case_eq_if Lmap.lemma_ab lappend.disc_iff(1) lappend.simps(3) lappend.simps(4) lmap.disc_iff(2) lmap.sel(1))

end