diff --git a/thys/Registers/Axioms_Complement_Quantum.thy b/thys/Registers/Axioms_Complement_Quantum.thy
--- a/thys/Registers/Axioms_Complement_Quantum.thy
+++ b/thys/Registers/Axioms_Complement_Quantum.thy
@@ -1,711 +1,711 @@
 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 Missing_Permutations.inj_on_finite by blast
+    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 daws21unitalanswer}\<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, hide_lams) Misc.sandwich_def T \<gamma> \<open>\<gamma> = 1\<close> adj_cblinfun_compose butterfly_adjoint cblinfun_comp_butterfly scaleC_one tensor_butterfly)
+    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, hide_lams) calculation cblinfun_image_ccspan cblinfun_image_mono eq_iff top_greatest)
+      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, hide_lams) \<open>unitary U\<close> isometryD cblinfun_assoc_left(1) cblinfun_compose_id_right cblinfun_compose_id_left unitary_isometry)
+       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, hide_lams) \<open>F \<circ> G = id\<close> \<open>G o F = id\<close> \<open>register G\<close> comp_def eq_id_iff register_def)
+    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, hide_lams) \<open>G \<circ> F = id\<close> \<open>F \<circ> G = id\<close> image_iff pointfree_idE)
+    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
diff --git a/thys/Registers/Laws.thy b/thys/Registers/Laws.thy
--- a/thys/Registers/Laws.thy
+++ b/thys/Registers/Laws.thy
@@ -1,814 +1,814 @@
 section \<open>Generic laws about registers\<close>
 
 theory Laws
   imports Axioms
 begin
 
 text \<open>This notation is only used inside this file\<close>
 notation comp_update (infixl "*\<^sub>u" 55)
 notation tensor_update (infixr "\<otimes>\<^sub>u" 70)
 notation register_pair ("'(_;_')")
 
 subsection \<open>Elementary facts\<close>
 
 declare id_preregister[simp]
 declare id_update_left[simp]
 declare id_update_right[simp]
 declare register_preregister[simp]
 declare register_comp[simp]
 declare register_of_id[simp]
 declare register_tensor_left[simp]
 declare register_tensor_right[simp]
 declare preregister_mult_right[simp]
 declare preregister_mult_left[simp]
 declare register_id[simp]
 
 subsection \<open>Preregisters\<close>
 
 lemma preregister_tensor_left[simp]: \<open>preregister (\<lambda>b::'b::domain update. tensor_update a b)\<close>
   for a :: \<open>'a::domain update\<close>
 proof -
   have \<open>preregister ((\<lambda>b1::('a\<times>'b) update. (a \<otimes>\<^sub>u id_update) *\<^sub>u b1) o (\<lambda>b. tensor_update id_update b))\<close>
     by (rule comp_preregister; simp)
   then show ?thesis
     by (simp add: o_def tensor_update_mult)
 qed
 
 lemma preregister_tensor_right[simp]: \<open>preregister (\<lambda>a::'a::domain update. tensor_update a b)\<close>  
   for b :: \<open>'b::domain update\<close>
 proof -
   have \<open>preregister ((\<lambda>a1::('a\<times>'b) update. (id_update \<otimes>\<^sub>u b) *\<^sub>u a1) o (\<lambda>a. tensor_update a id_update))\<close>
     by (rule comp_preregister, simp_all)
   then show ?thesis
     by (simp add: o_def tensor_update_mult)
 qed
 
 subsection \<open>Registers\<close>
 
 lemma id_update_tensor_register[simp]:
   assumes \<open>register F\<close>
   shows \<open>register (\<lambda>a::'a::domain update. id_update \<otimes>\<^sub>u F a)\<close>
   using assms apply (rule register_comp[unfolded o_def])
   by simp
 
 lemma register_tensor_id_update[simp]:
   assumes \<open>register F\<close>
   shows \<open>register (\<lambda>a::'a::domain update. F a \<otimes>\<^sub>u id_update)\<close>
   using assms apply (rule register_comp[unfolded o_def])
   by simp
 
 subsection \<open>Tensor product of registers\<close>
 
 definition register_tensor  (infixr "\<otimes>\<^sub>r" 70) where
   "register_tensor F G = register_pair (\<lambda>a. tensor_update (F a) id_update) (\<lambda>b. tensor_update id_update (G b))"
 
 lemma register_tensor_is_register: 
   fixes F :: "'a::domain update \<Rightarrow> 'b::domain update" and G :: "'c::domain update \<Rightarrow> 'd::domain update"
   shows "register F \<Longrightarrow> register G \<Longrightarrow> register (F \<otimes>\<^sub>r G)"
   unfolding register_tensor_def
   apply (rule register_pair_is_register)
   by (simp_all add: tensor_update_mult)
 
 lemma register_tensor_apply[simp]:
   fixes F :: "'a::domain update \<Rightarrow> 'b::domain update" and G :: "'c::domain update \<Rightarrow> 'd::domain update"
   assumes \<open>register F\<close> and \<open>register G\<close>
   shows "(F \<otimes>\<^sub>r G) (a \<otimes>\<^sub>u b) = F a \<otimes>\<^sub>u G b"
   unfolding register_tensor_def
   apply (subst register_pair_apply)
   unfolding register_tensor_def 
   by (simp_all add: assms tensor_update_mult)
 
 definition "separating (_::'b::domain itself) A \<longleftrightarrow> 
   (\<forall>F G :: 'a::domain update \<Rightarrow> 'b update. preregister F \<longrightarrow> preregister G \<longrightarrow> (\<forall>x\<in>A. F x = G x) \<longrightarrow> F = G)"
 
 lemma separating_UNIV[simp]: \<open>separating TYPE(_) UNIV\<close>
   unfolding separating_def by auto
 
 lemma separating_mono: \<open>A \<subseteq> B \<Longrightarrow> separating TYPE('a::domain) A \<Longrightarrow> separating TYPE('a) B\<close>
   unfolding separating_def by (meson in_mono) 
 
 lemma register_eqI: \<open>separating TYPE('b::domain) A \<Longrightarrow> preregister F \<Longrightarrow> preregister G \<Longrightarrow> (\<And>x. x\<in>A \<Longrightarrow> F x = G x) \<Longrightarrow> F = (G::_ \<Rightarrow> 'b update)\<close>
   unfolding separating_def by auto
 
 lemma separating_tensor:
   fixes A :: \<open>'a::domain update set\<close> and B :: \<open>'b::domain update set\<close>
   assumes [simp]: \<open>separating TYPE('c::domain) A\<close>
   assumes [simp]: \<open>separating TYPE('c) B\<close>
   shows \<open>separating TYPE('c) {a \<otimes>\<^sub>u b | a b. a\<in>A \<and> b\<in>B}\<close>
 proof (unfold separating_def, intro allI impI)
   fix F G :: \<open>('a\<times>'b) update \<Rightarrow> 'c update\<close>
   assume [simp]: \<open>preregister F\<close> \<open>preregister G\<close>
   have [simp]: \<open>preregister (\<lambda>x. F (a \<otimes>\<^sub>u x))\<close> for a
     using _ \<open>preregister F\<close> apply (rule comp_preregister[unfolded o_def])
     by simp
   have [simp]: \<open>preregister (\<lambda>x. G (a \<otimes>\<^sub>u x))\<close> for a
     using _ \<open>preregister G\<close> apply (rule comp_preregister[unfolded o_def])
     by simp
   have [simp]: \<open>preregister (\<lambda>x. F (x \<otimes>\<^sub>u b))\<close> for b
     using _ \<open>preregister F\<close> apply (rule comp_preregister[unfolded o_def])
     by simp
   have [simp]: \<open>preregister (\<lambda>x. G (x \<otimes>\<^sub>u b))\<close> for b
     using _ \<open>preregister G\<close> apply (rule comp_preregister[unfolded o_def])
     by simp
 
   assume \<open>\<forall>x\<in>{a \<otimes>\<^sub>u b |a b. a\<in>A \<and> b\<in>B}. F x = G x\<close>
   then have EQ: \<open>F (a \<otimes>\<^sub>u b) = G (a \<otimes>\<^sub>u b)\<close> if \<open>a \<in> A\<close> and \<open>b \<in> B\<close> for a b
     using that by auto
   then have \<open>F (a \<otimes>\<^sub>u b) = G (a \<otimes>\<^sub>u b)\<close> if \<open>a \<in> A\<close> for a b
     apply (rule register_eqI[where A=B, THEN fun_cong, where x=b, rotated -1])
     using that by auto
   then have \<open>F (a \<otimes>\<^sub>u b) = G (a \<otimes>\<^sub>u b)\<close> for a b
     apply (rule register_eqI[where A=A, THEN fun_cong, where x=a, rotated -1])
     by auto
   then show "F = G"
     apply (rule tensor_extensionality[rotated -1])
     by auto
 qed
 
 lemma register_tensor_distrib:
   assumes [simp]: \<open>register F\<close> \<open>register G\<close> \<open>register H\<close> \<open>register L\<close>
   shows \<open>(F \<otimes>\<^sub>r G) o (H \<otimes>\<^sub>r L) = (F o H) \<otimes>\<^sub>r (G o L)\<close>
   apply (rule tensor_extensionality)
   by (auto intro!: register_comp register_preregister register_tensor_is_register)
 
 text \<open>The following is easier to apply using the @{method rule}-method than @{thm [source] separating_tensor}\<close>
 lemma separating_tensor':
   fixes A :: \<open>'a::domain update set\<close> and B :: \<open>'b::domain update set\<close>
   assumes \<open>separating TYPE('c::domain) A\<close>
   assumes \<open>separating TYPE('c) B\<close>
   assumes \<open>C = {a \<otimes>\<^sub>u b | a b. a\<in>A \<and> b\<in>B}\<close>
   shows \<open>separating TYPE('c) C\<close>
   using assms
   by (simp add: separating_tensor)
 
 lemma tensor_extensionality3: 
   fixes F G :: \<open>('a::domain\<times>'b::domain\<times>'c::domain) update \<Rightarrow> 'd::domain update\<close>
   assumes [simp]: \<open>register F\<close> \<open>register G\<close>
   assumes "\<And>f g h. F (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h) = G (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h)"
   shows "F = G"
 proof (rule register_eqI[where A=\<open>{a\<otimes>\<^sub>ub\<otimes>\<^sub>uc| a b c. True}\<close>])
   have \<open>separating TYPE('d) {b \<otimes>\<^sub>u c |b c. True}\<close>
     apply (rule separating_tensor'[where A=UNIV and B=UNIV])
     by auto
   then show \<open>separating TYPE('d) {a \<otimes>\<^sub>u b \<otimes>\<^sub>u c |a b c. True}\<close>
     apply (rule_tac separating_tensor'[where A=UNIV and B=\<open>{b\<otimes>\<^sub>uc| b c. True}\<close>])
     by auto
   show \<open>preregister F\<close> \<open>preregister G\<close> by auto
   show \<open>x \<in> {a \<otimes>\<^sub>u b \<otimes>\<^sub>u c |a b c. True} \<Longrightarrow> F x = G x\<close> for x
     using assms(3) by auto
 qed
 
 lemma tensor_extensionality3': 
   fixes F G :: \<open>(('a::domain\<times>'b::domain)\<times>'c::domain) update \<Rightarrow> 'd::domain update\<close>
   assumes [simp]: \<open>register F\<close> \<open>register G\<close>
   assumes "\<And>f g h. F ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h) = G ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h)"
   shows "F = G"
 proof (rule register_eqI[where A=\<open>{(a\<otimes>\<^sub>ub)\<otimes>\<^sub>uc| a b c. True}\<close>])
   have \<open>separating TYPE('d) {a \<otimes>\<^sub>u b | a b. True}\<close>
     apply (rule separating_tensor'[where A=UNIV and B=UNIV])
     by auto
   then show \<open>separating TYPE('d) {(a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c |a b c. True}\<close>
     apply (rule_tac separating_tensor'[where B=UNIV and A=\<open>{a\<otimes>\<^sub>ub| a b. True}\<close>])
     by auto
   show \<open>preregister F\<close> \<open>preregister G\<close> by auto
   show \<open>x \<in> {(a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c |a b c. True} \<Longrightarrow> F x = G x\<close> for x
     using assms(3) by auto
 qed
 
 lemma register_tensor_id[simp]: \<open>id \<otimes>\<^sub>r id = id\<close>
   apply (rule tensor_extensionality)
   by (auto simp add: register_tensor_is_register)
 
 subsection \<open>Pairs and compatibility\<close>
 
 definition compatible :: \<open>('a::domain update \<Rightarrow> 'c::domain update)
                        \<Rightarrow> ('b::domain update \<Rightarrow> 'c update) \<Rightarrow> bool\<close> where
   \<open>compatible F G \<longleftrightarrow> register F \<and> register G \<and> (\<forall>a b. F a *\<^sub>u G b = G b *\<^sub>u F a)\<close>
 
 lemma compatibleI:
   assumes "register F" and "register G"
   assumes \<open>\<And>a b. (F a) *\<^sub>u (G b) = (G b) *\<^sub>u (F a)\<close>
   shows "compatible F G"
   using assms unfolding compatible_def by simp
 
 lemma swap_registers:
   assumes "compatible R S"
   shows "R a *\<^sub>u S b = S b *\<^sub>u R a"
   using assms unfolding compatible_def by metis
 
 lemma compatible_sym: "compatible x y \<Longrightarrow> compatible y x"
   by (simp add: compatible_def)
 
 lemma pair_is_register[simp]:
   assumes "compatible F G"
   shows "register (F; G)"
   by (metis assms compatible_def register_pair_is_register)
 
 lemma register_pair_apply:
   assumes \<open>compatible F G\<close>
   shows \<open>(F; G) (a \<otimes>\<^sub>u b) = (F a) *\<^sub>u (G b)\<close>
   apply (rule register_pair_apply)
   using assms unfolding compatible_def by metis+
 
 lemma register_pair_apply':
   assumes \<open>compatible F G\<close>
   shows \<open>(F; G) (a \<otimes>\<^sub>u b) = (G b) *\<^sub>u (F a)\<close>
   apply (subst register_pair_apply)
   using assms by (auto simp: compatible_def intro: register_preregister)
 
 
 
 lemma compatible_comp_left[simp]: "compatible F G \<Longrightarrow> register H \<Longrightarrow> compatible (F \<circ> H) G"
   by (simp add: compatible_def)
 
 lemma compatible_comp_right[simp]: "compatible F G \<Longrightarrow> register H \<Longrightarrow> compatible F (G \<circ> H)"
   by (simp add: compatible_def)
 
 lemma compatible_comp_inner[simp]: 
   "compatible F G \<Longrightarrow> register H \<Longrightarrow> compatible (H \<circ> F) (H \<circ> G)"
   by (smt (verit, best) comp_apply compatible_def register_comp register_mult)
 
 lemma compatible_register1: \<open>compatible F G \<Longrightarrow> register F\<close>
   by (simp add: compatible_def)
 lemma compatible_register2: \<open>compatible F G \<Longrightarrow> register G\<close>
   by (simp add: compatible_def)
 
 lemma pair_o_tensor:
   assumes "compatible A B" and [simp]: \<open>register C\<close> and [simp]: \<open>register D\<close>
   shows "(A; B) o (C \<otimes>\<^sub>r D) = (A o C; B o D)"
   apply (rule tensor_extensionality)
   using assms by (simp_all add: register_tensor_is_register register_pair_apply comp_preregister)
 
 lemma compatible_tensor_id_update_left[simp]:
   fixes F :: "'a::domain update \<Rightarrow> 'c::domain update" and G :: "'b::domain update \<Rightarrow> 'c::domain update"
   assumes "compatible F G"
   shows "compatible (\<lambda>a. id_update \<otimes>\<^sub>u F a) (\<lambda>a. id_update \<otimes>\<^sub>u G a)"
   using assms apply (rule compatible_comp_inner[unfolded o_def])
   by simp
 
 lemma compatible_tensor_id_update_right[simp]:
   fixes F :: "'a::domain update \<Rightarrow> 'c::domain update" and G :: "'b::domain update \<Rightarrow> 'c::domain update"
   assumes "compatible F G"
   shows "compatible (\<lambda>a. F a \<otimes>\<^sub>u id_update) (\<lambda>a. G a \<otimes>\<^sub>u id_update)"
   using assms apply (rule compatible_comp_inner[unfolded o_def])
   by simp
 
 lemma compatible_tensor_id_update_rl[simp]:
   assumes "register F" and "register G"
   shows "compatible (\<lambda>a. F a \<otimes>\<^sub>u id_update) (\<lambda>a. id_update \<otimes>\<^sub>u G a)"
   apply (rule compatibleI)
   using assms by (auto simp: tensor_update_mult)
 
 lemma compatible_tensor_id_update_lr[simp]:
   assumes "register F" and "register G"
   shows "compatible (\<lambda>a. id_update \<otimes>\<^sub>u F a) (\<lambda>a. G a \<otimes>\<^sub>u id_update)"
   apply (rule compatibleI)
   using assms by (auto simp: tensor_update_mult)
 
 lemma register_comp_pair:
   assumes [simp]: \<open>register F\<close> and [simp]: \<open>compatible G H\<close>
   shows "(F o G; F o H) = F o (G; H)"
 proof (rule tensor_extensionality)
   show \<open>preregister (F \<circ> G;F \<circ> H)\<close> and \<open>preregister (F \<circ> (G;H))\<close>
     by simp_all
 
   have [simp]: \<open>compatible (F o G) (F o H)\<close>
     apply (rule compatible_comp_inner, simp)
     by simp
   then have [simp]: \<open>register (F \<circ> G)\<close> \<open>register (F \<circ> H)\<close>
     unfolding compatible_def by auto
   from assms have [simp]: \<open>register G\<close> \<open>register H\<close>
     unfolding compatible_def by auto
   fix a b
   show \<open>(F \<circ> G;F \<circ> H) (a \<otimes>\<^sub>u b) = (F \<circ> (G;H)) (a \<otimes>\<^sub>u b)\<close>
     by (auto simp: register_pair_apply register_mult tensor_update_mult)
 qed
 
 lemma swap_registers_left:
   assumes "compatible R S"
   shows "R a *\<^sub>u S b *\<^sub>u c = S b *\<^sub>u R a *\<^sub>u c"
   using assms unfolding compatible_def by metis
 
 lemma swap_registers_right:
   assumes "compatible R S"
   shows "c *\<^sub>u R a *\<^sub>u S b = c *\<^sub>u S b *\<^sub>u R a"
   by (metis assms comp_update_assoc compatible_def)
 
 lemmas compatible_ac_rules = swap_registers comp_update_assoc[symmetric] swap_registers_right
 
 subsection \<open>Fst and Snd\<close>
 
 definition Fst where \<open>Fst a = a \<otimes>\<^sub>u id_update\<close>
 definition Snd where \<open>Snd a = id_update \<otimes>\<^sub>u a\<close>
 
 lemma register_Fst[simp]: \<open>register Fst\<close>
   unfolding Fst_def by (rule register_tensor_left)
 
 lemma register_Snd[simp]: \<open>register Snd\<close>
   unfolding Snd_def by (rule register_tensor_right)
 
 lemma compatible_Fst_Snd[simp]: \<open>compatible Fst Snd\<close>
   apply (rule compatibleI, simp, simp)
   by (simp add: Fst_def Snd_def tensor_update_mult)
 
 lemmas compatible_Snd_Fst[simp] = compatible_Fst_Snd[THEN compatible_sym]
 
 definition \<open>swap = (Snd; Fst)\<close>
 
 lemma swap_apply[simp]: "swap (a \<otimes>\<^sub>u b) = (b \<otimes>\<^sub>u a)"
   unfolding swap_def
   by (simp add: Axioms.register_pair_apply Fst_def Snd_def tensor_update_mult) 
 
 lemma swap_o_Fst: "swap o Fst = Snd"
   by (auto simp add: Fst_def Snd_def)
 lemma swap_o_Snd: "swap o Snd = Fst"
   by (auto simp add: Fst_def Snd_def)
 
 lemma register_swap[simp]: \<open>register swap\<close>
   by (simp add: swap_def)
 
 lemma pair_Fst_Snd: \<open>(Fst; Snd) = id\<close>
   apply (rule tensor_extensionality)
   by (simp_all add: register_pair_apply Fst_def Snd_def tensor_update_mult)
 
 lemma swap_o_swap[simp]: \<open>swap o swap = id\<close>
   by (metis swap_def compatible_Snd_Fst pair_Fst_Snd register_comp_pair register_swap swap_o_Fst swap_o_Snd)
 
 lemma swap_swap[simp]: \<open>swap (swap x) = x\<close>
   by (simp add: pointfree_idE)
 
 lemma inv_swap[simp]: \<open>inv swap = swap\<close>
   by (meson inv_unique_comp swap_o_swap)
 
 lemma register_pair_Fst:
   assumes \<open>compatible F G\<close>
   shows \<open>(F;G) o Fst = F\<close>
   using assms by (auto intro!: ext simp: Fst_def register_pair_apply compatible_register2)
 
 lemma register_pair_Snd:
   assumes \<open>compatible F G\<close>
   shows \<open>(F;G) o Snd = G\<close>
   using assms by (auto intro!: ext simp: Snd_def register_pair_apply compatible_register1)
 
 lemma register_Fst_register_Snd[simp]:
   assumes \<open>register F\<close>
   shows \<open>(F o Fst; F o Snd) = F\<close>
   apply (rule tensor_extensionality)
   using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult tensor_update_mult)
 
 lemma register_Snd_register_Fst[simp]: 
   assumes \<open>register F\<close>
   shows \<open>(F o Snd; F o Fst) = F o swap\<close>
   apply (rule tensor_extensionality)
   using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult tensor_update_mult)
 
 
 lemma compatible3[simp]:
   assumes [simp]: "compatible F G" and "compatible G H" and "compatible F H"
   shows "compatible (F; G) H"
 proof (rule compatibleI)
   have [simp]: \<open>register F\<close> \<open>register G\<close> \<open>register H\<close>
     using assms compatible_def by auto
   then have [simp]: \<open>preregister F\<close> \<open>preregister G\<close> \<open>preregister H\<close>
     using register_preregister by blast+
   have [simp]: \<open>preregister (\<lambda>a. (F;G) a *\<^sub>u z)\<close> for z
     apply (rule comp_preregister[unfolded o_def, of \<open>(F;G)\<close>])
     by simp_all
   have [simp]: \<open>preregister (\<lambda>a. z *\<^sub>u (F;G) a)\<close> for z
     apply (rule comp_preregister[unfolded o_def, of \<open>(F;G)\<close>])
     by simp_all
   have "(F; G) (f \<otimes>\<^sub>u g) *\<^sub>u H h = H h *\<^sub>u (F; G) (f \<otimes>\<^sub>u g)" for f g h
   proof -
     have FH: "F f *\<^sub>u H h = H h *\<^sub>u F f"
       using assms compatible_def by metis
     have GH: "G g *\<^sub>u H h = H h *\<^sub>u G g"
       using assms compatible_def by metis
     have \<open>(F; G) (f \<otimes>\<^sub>u g) *\<^sub>u (H h) = F f *\<^sub>u G g *\<^sub>u H h\<close>
       using \<open>compatible F G\<close> by (subst register_pair_apply, auto)
     also have \<open>\<dots> = H h *\<^sub>u F f *\<^sub>u G g\<close>
       using FH GH by (metis comp_update_assoc)
     also have \<open>\<dots> = H h *\<^sub>u (F; G) (f \<otimes>\<^sub>u g)\<close>
       using \<open>compatible F G\<close> by (subst register_pair_apply, auto simp: comp_update_assoc)
     finally show ?thesis
       by -
   qed
   then show "(F; G) fg *\<^sub>u (H h) = (H h) *\<^sub>u (F; G) fg" for fg h
     apply (rule_tac tensor_extensionality[THEN fun_cong])
     by auto
   show "register H" and  "register (F; G)"
     by simp_all
 qed
 
 lemma compatible3'[simp]:
   assumes "compatible F G" and "compatible G H" and "compatible F H"
   shows "compatible F (G; H)"
   apply (rule compatible_sym)
   apply (rule compatible3)
   using assms by (auto simp: compatible_sym)
 
 lemma pair_o_swap[simp]:
   assumes [simp]: "compatible A B"
   shows "(A; B) o swap = (B; A)"
 proof (rule tensor_extensionality)
   have [simp]: "preregister A" "preregister B"
-     apply (metis (no_types, hide_lams) assms compatible_register1 register_preregister)
+     apply (metis (no_types, opaque_lifting) assms compatible_register1 register_preregister)
     by (metis (full_types) assms compatible_register2 register_preregister)
   then show \<open>preregister ((A; B) \<circ> swap)\<close>
     by simp
   show \<open>preregister (B; A)\<close>
     by (metis (no_types, lifting) assms compatible_sym register_preregister pair_is_register)
   show \<open>((A; B) \<circ> swap) (a \<otimes>\<^sub>u b) = (B; A) (a \<otimes>\<^sub>u b)\<close> for a b
     (* Without the "only:", we would not need the "apply subst",
        but that proof fails when instantiated in Classical.thy *)
     apply (simp only: o_def swap_apply)
     apply (subst register_pair_apply, simp)
     apply (subst register_pair_apply, simp add: compatible_sym)
     by (metis (no_types, lifting) assms compatible_def)
 qed
 
 
 subsection \<open>Compatibility of register tensor products\<close>
 
 lemma compatible_register_tensor:
   fixes F :: \<open>'a::domain update \<Rightarrow> 'e::domain update\<close> and G :: \<open>'b::domain update \<Rightarrow> 'f::domain update\<close>
     and F' :: \<open>'c::domain update \<Rightarrow> 'e update\<close> and G' :: \<open>'d::domain update \<Rightarrow> 'f update\<close>
   assumes [simp]: \<open>compatible F F'\<close>
   assumes [simp]: \<open>compatible G G'\<close>
   shows \<open>compatible (F \<otimes>\<^sub>r G) (F' \<otimes>\<^sub>r G')\<close>
 proof -
   note [intro!] = 
     comp_preregister[OF _ preregister_mult_right, unfolded o_def]
     comp_preregister[OF _ preregister_mult_left, unfolded o_def]
     comp_preregister
     register_tensor_is_register
   have [simp]: \<open>register F\<close> \<open>register G\<close> \<open>register F'\<close> \<open>register G'\<close>
     using assms compatible_def by blast+
   have [simp]: \<open>register (F \<otimes>\<^sub>r G)\<close> \<open>register (F' \<otimes>\<^sub>r G')\<close>
     by (auto simp add: register_tensor_def)
   have [simp]: \<open>register (F;F')\<close> \<open>register (G;G')\<close>
     by auto
   define reorder :: \<open>(('a\<times>'b) \<times> ('c\<times>'d)) update \<Rightarrow> (('a\<times>'c) \<times> ('b\<times>'d)) update\<close>
     where \<open>reorder = ((Fst o Fst; Snd o Fst); (Fst o Snd; Snd o Snd))\<close>
   have [simp]: \<open>preregister reorder\<close>
     by (auto simp: reorder_def)
   have [simp]: \<open>reorder ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u (c \<otimes>\<^sub>u d)) = ((a \<otimes>\<^sub>u c) \<otimes>\<^sub>u (b \<otimes>\<^sub>u d))\<close> for a b c d
     apply (simp add: reorder_def register_pair_apply)
     by (simp add: Fst_def Snd_def tensor_update_mult)
   define \<Phi> where \<open>\<Phi> c d = ((F;F') \<otimes>\<^sub>r (G;G')) o reorder o (\<lambda>\<sigma>. \<sigma> \<otimes>\<^sub>u (c \<otimes>\<^sub>u d))\<close> for c d
   have [simp]: \<open>preregister (\<Phi> c d)\<close> for c d
     unfolding \<Phi>_def 
     by (auto intro: register_preregister)
   have \<open>\<Phi> c d (a \<otimes>\<^sub>u b) = (F \<otimes>\<^sub>r G) (a \<otimes>\<^sub>u b) *\<^sub>u (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d)\<close> for a b c d
     unfolding \<Phi>_def by (auto simp: register_pair_apply tensor_update_mult)
   then have \<Phi>1: \<open>\<Phi> c d \<sigma> = (F \<otimes>\<^sub>r G) \<sigma> *\<^sub>u (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d)\<close> for c d \<sigma>
     apply (rule_tac fun_cong[of _ _ \<sigma>])
     apply (rule tensor_extensionality)
     by auto
   have \<open>\<Phi> c d (a \<otimes>\<^sub>u b) = (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d) *\<^sub>u (F \<otimes>\<^sub>r G) (a \<otimes>\<^sub>u b)\<close> for a b c d
     unfolding \<Phi>_def apply (auto simp: register_pair_apply)
     by (metis assms(1) assms(2) compatible_def tensor_update_mult)
   then have \<Phi>2: \<open>\<Phi> c d \<sigma> = (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d) *\<^sub>u (F \<otimes>\<^sub>r G) \<sigma>\<close> for c d \<sigma>
     apply (rule_tac fun_cong[of _ _ \<sigma>])
     apply (rule tensor_extensionality)
     by auto
   from \<Phi>1 \<Phi>2 have \<open>(F \<otimes>\<^sub>r G) \<sigma> *\<^sub>u (F' \<otimes>\<^sub>r G') \<tau> = (F' \<otimes>\<^sub>r G') \<tau> *\<^sub>u (F \<otimes>\<^sub>r G) \<sigma>\<close> for \<tau> \<sigma>
     apply (rule_tac fun_cong[of _ _ \<tau>])
     apply (rule tensor_extensionality)
     by auto
   then show ?thesis
     apply (rule compatibleI[rotated -1])
     by auto
 qed
 
 subsection \<open>Associativity of the tensor product\<close>
 
 definition assoc :: \<open>(('a::domain\<times>'b::domain)\<times>'c::domain) update \<Rightarrow> ('a\<times>('b\<times>'c)) update\<close> where 
   \<open>assoc = ((Fst; Snd o Fst); Snd o Snd)\<close>
 
 lemma assoc_is_hom[simp]: \<open>preregister assoc\<close>
   by (auto simp: assoc_def)
 
 lemma assoc_apply[simp]: \<open>assoc ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c) = (a \<otimes>\<^sub>u (b \<otimes>\<^sub>u c))\<close>
   by (auto simp: assoc_def register_pair_apply Fst_def Snd_def tensor_update_mult)
 
 definition assoc' :: \<open>('a\<times>('b\<times>'c)) update \<Rightarrow> (('a::domain\<times>'b::domain)\<times>'c::domain) update\<close> where 
   \<open>assoc' = (Fst o Fst; (Fst o Snd; Snd))\<close>
 
 lemma assoc'_is_hom[simp]: \<open>preregister assoc'\<close>
   by (auto simp: assoc'_def)
 
 lemma assoc'_apply[simp]: \<open>assoc' (a \<otimes>\<^sub>u (b \<otimes>\<^sub>u c)) =  ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c)\<close>
   by (auto simp: assoc'_def register_pair_apply Fst_def Snd_def tensor_update_mult)
 
 lemma register_assoc[simp]: \<open>register assoc\<close>
   unfolding assoc_def
   by force
 
 lemma register_assoc'[simp]: \<open>register assoc'\<close>
   unfolding assoc'_def 
   by force
 
 lemma pair_o_assoc[simp]:
   assumes [simp]: \<open>compatible F G\<close> \<open>compatible G H\<close> \<open>compatible F H\<close>
   shows \<open>(F; (G; H)) \<circ> assoc = ((F; G); H)\<close>
 proof (rule tensor_extensionality3')
   show \<open>register ((F; (G; H)) \<circ> assoc)\<close>
     by simp
   show \<open>register ((F; G); H)\<close>
     by simp
   show \<open>((F; (G; H)) \<circ> assoc) ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h) = ((F; G); H) ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h)\<close> for f g h
     by (simp add: register_pair_apply assoc_apply comp_update_assoc)
 qed
 
 lemma pair_o_assoc'[simp]:
   assumes [simp]: \<open>compatible F G\<close> \<open>compatible G H\<close> \<open>compatible F H\<close>
   shows \<open>((F; G); H) \<circ> assoc' = (F; (G; H))\<close>
 proof (rule tensor_extensionality3)
   show \<open>register (((F; G); H) \<circ> assoc')\<close>
     by simp
   show \<open>register (F; (G; H))\<close>
     by simp
   show \<open>(((F; G); H) \<circ> assoc') (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h) = (F; (G; H)) (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h)\<close> for f g h
     by (simp add: register_pair_apply assoc'_apply comp_update_assoc)
 qed
 
 lemma assoc'_o_assoc[simp]: \<open>assoc' o assoc = id\<close>
   apply (rule tensor_extensionality3')
   by auto
 
 lemma assoc'_assoc[simp]: \<open>assoc' (assoc x) = x\<close>
   by (simp add: pointfree_idE)
 
 lemma assoc_o_assoc'[simp]: \<open>assoc o assoc' = id\<close>
   apply (rule tensor_extensionality3)
   by auto
 
 lemma assoc_assoc'[simp]: \<open>assoc (assoc' x) = x\<close>
   by (simp add: pointfree_idE)
 
 lemma inv_assoc[simp]: \<open>inv assoc = assoc'\<close>
   using assoc'_o_assoc assoc_o_assoc' inv_unique_comp by blast
 
 lemma inv_assoc'[simp]: \<open>inv assoc' = assoc\<close>
   by (simp add: inv_equality)
 
 lemma [simp]: \<open>bij assoc\<close>
   using assoc'_o_assoc assoc_o_assoc' o_bij by blast
 
 lemma [simp]: \<open>bij assoc'\<close>
   using assoc'_o_assoc assoc_o_assoc' o_bij by blast
 
 subsection \<open>Iso-registers\<close>
 
 definition \<open>iso_register F \<longleftrightarrow> register F \<and> (\<exists>G. register G \<and> F o G = id \<and> G o F = id)\<close>
   for F :: \<open>_::domain update \<Rightarrow> _::domain update\<close>
 
 lemma iso_registerI:
   assumes \<open>register F\<close> \<open>register G\<close> \<open>F o G = id\<close> \<open>G o F = id\<close>
   shows \<open>iso_register F\<close>
   using assms(1) assms(2) assms(3) assms(4) iso_register_def by blast
 
 lemma iso_register_inv: \<open>iso_register F \<Longrightarrow> iso_register (inv F)\<close>
   by (metis inv_unique_comp iso_register_def)
 
 lemma iso_register_inv_comp1: \<open>iso_register F \<Longrightarrow> inv F o F = id\<close>
   using inv_unique_comp iso_register_def by blast
 
 lemma iso_register_inv_comp2: \<open>iso_register F \<Longrightarrow> F o inv F = id\<close>
   using inv_unique_comp iso_register_def by blast
 
 
 lemma iso_register_id[simp]: \<open>iso_register id\<close>
   by (simp add: iso_register_def)
 
 lemma iso_register_is_register: \<open>iso_register F \<Longrightarrow> register F\<close>
   using iso_register_def by blast
 
 lemma iso_register_comp[simp]:
   assumes [simp]: \<open>iso_register F\<close> \<open>iso_register G\<close>
   shows \<open>iso_register (F o G)\<close>
 proof -
   from assms obtain F' G' where [simp]: \<open>register F'\<close> \<open>register G'\<close> \<open>F o F' = id\<close> \<open>F' o F = id\<close>
     \<open>G o G' = id\<close> \<open>G' o G = id\<close>
     by (meson iso_register_def)
   show ?thesis
     apply (rule iso_registerI[where G=\<open>G' o F'\<close>])
        apply (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
      apply (metis \<open>F \<circ> F' = id\<close> \<open>G \<circ> G' = id\<close> fcomp_assoc fcomp_comp id_fcomp)
     by (metis (no_types, lifting) \<open>F \<circ> F' = id\<close> \<open>F' \<circ> F = id\<close> \<open>G' \<circ> G = id\<close> fun.map_comp inj_iff inv_unique_comp o_inv_o_cancel)
 qed
 
 
 lemma iso_register_tensor_is_iso_register[simp]:
   assumes [simp]: \<open>iso_register F\<close> \<open>iso_register G\<close>
   shows \<open>iso_register (F \<otimes>\<^sub>r G)\<close>
 proof -
   from assms obtain F' G' where [simp]: \<open>register F'\<close> \<open>register G'\<close> \<open>F o F' = id\<close> \<open>F' o F = id\<close>
     \<open>G o G' = id\<close> \<open>G' o G = id\<close>
     by (meson iso_register_def)
   show ?thesis
     apply (rule iso_registerI[where G=\<open>F' \<otimes>\<^sub>r G'\<close>])
     by (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
 qed
 
 lemma iso_register_bij: \<open>iso_register F \<Longrightarrow> bij F\<close>
   using iso_register_def o_bij by auto
 
 lemma inv_register_tensor[simp]: 
   assumes [simp]: \<open>iso_register F\<close> \<open>iso_register G\<close>
   shows \<open>inv (F \<otimes>\<^sub>r G) = inv F \<otimes>\<^sub>r inv G\<close>
   apply (auto intro!: inj_imp_inv_eq bij_is_inj iso_register_bij 
               simp: register_tensor_distrib[unfolded o_def, THEN fun_cong] iso_register_is_register
                     iso_register_inv bij_is_surj iso_register_bij surj_f_inv_f)
   by (metis eq_id_iff register_tensor_id)
 
 lemma iso_register_swap[simp]: \<open>iso_register swap\<close>
   apply (rule iso_registerI[of _ swap])
   by auto
 
 lemma iso_register_assoc[simp]: \<open>iso_register assoc\<close>
   apply (rule iso_registerI[of _ assoc'])
   by auto
 
 lemma iso_register_assoc'[simp]: \<open>iso_register assoc'\<close>
   apply (rule iso_registerI[of _ assoc])
   by auto
 
 definition \<open>equivalent_registers F G \<longleftrightarrow> (register F \<and> (\<exists>I. iso_register I \<and> F o I = G))\<close>
   for F G :: \<open>_::domain update \<Rightarrow> _::domain update\<close>
 
 lemma iso_register_equivalent_id[simp]: \<open>equivalent_registers id F \<longleftrightarrow> iso_register F\<close>
   by (simp add: equivalent_registers_def)
 
 lemma equivalent_registersI:
   assumes \<open>register F\<close>
   assumes \<open>iso_register I\<close>
   assumes \<open>F o I = G\<close>
   shows \<open>equivalent_registers F G\<close>
   using assms unfolding equivalent_registers_def by blast
 
 lemma equivalent_registers_register_left: \<open>equivalent_registers F G \<Longrightarrow> register F\<close>
   using equivalent_registers_def by auto
 
 lemma equivalent_registers_register_right: \<open>register G\<close> if \<open>equivalent_registers F G\<close>
   by (metis equivalent_registers_def iso_register_def register_comp that)
 
 lemma equivalent_registers_sym:
   assumes \<open>equivalent_registers F G\<close>
   shows \<open>equivalent_registers G F\<close>
   by (smt (verit) assms comp_id equivalent_registers_def equivalent_registers_register_right fun.map_comp iso_register_def)
 
 lemma equivalent_registers_trans[trans]: 
   assumes \<open>equivalent_registers F G\<close> and \<open>equivalent_registers G H\<close>
   shows \<open>equivalent_registers F H\<close>
 proof -
   from assms have [simp]: \<open>register F\<close> \<open>register G\<close>
     by (auto simp: equivalent_registers_def)
   from assms(1) obtain I where [simp]: \<open>iso_register I\<close> and \<open>F o I = G\<close>
     using equivalent_registers_def by blast
   from assms(2) obtain J where [simp]: \<open>iso_register J\<close> and \<open>G o J = H\<close>
     using equivalent_registers_def by blast
   have \<open>register F\<close>
     by (auto simp: equivalent_registers_def)
   moreover have \<open>iso_register (I o J)\<close>
     using \<open>iso_register I\<close> \<open>iso_register J\<close> iso_register_comp by blast
   moreover have \<open>F o (I o J) = H\<close>
     by (simp add: \<open>F \<circ> I = G\<close> \<open>G \<circ> J = H\<close> o_assoc)
   ultimately show ?thesis
     by (rule equivalent_registersI)
 qed
 
 lemma equivalent_registers_assoc[simp]:
   assumes [simp]: \<open>compatible F G\<close> \<open>compatible F H\<close> \<open>compatible G H\<close>
   shows \<open>equivalent_registers (F;(G;H)) ((F;G);H)\<close>
   apply (rule equivalent_registersI[where I=assoc])
   by auto
 
 lemma equivalent_registers_pair_right:
   assumes [simp]: \<open>compatible F G\<close>
   assumes eq: \<open>equivalent_registers G H\<close>
   shows \<open>equivalent_registers (F;G) (F;H)\<close>
 proof -
   from eq obtain I where [simp]: \<open>iso_register I\<close> and \<open>G o I = H\<close>
     by (metis equivalent_registers_def)
   then have *: \<open>(F;G) \<circ> (id \<otimes>\<^sub>r I) = (F;H)\<close>
     by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register 
         simp:  register_pair_apply iso_register_is_register)
   show ?thesis
     apply (rule equivalent_registersI[where I=\<open>id \<otimes>\<^sub>r I\<close>])
     using * by (auto intro!: iso_register_tensor_is_iso_register)
 qed
 
 lemma equivalent_registers_pair_left:
   assumes [simp]: \<open>compatible F G\<close>
   assumes eq: \<open>equivalent_registers F H\<close>
   shows \<open>equivalent_registers (F;G) (H;G)\<close>
 proof -
   from eq obtain I where [simp]: \<open>iso_register I\<close> and \<open>F o I = H\<close>
     by (metis equivalent_registers_def)
   then have *: \<open>(F;G) \<circ> (I \<otimes>\<^sub>r id) = (H;G)\<close>
     by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register 
         simp:  register_pair_apply iso_register_is_register)
   show ?thesis
     apply (rule equivalent_registersI[where I=\<open>I \<otimes>\<^sub>r id\<close>])
     using * by (auto intro!: iso_register_tensor_is_iso_register)
 qed
 
 lemma equivalent_registers_comp:
   assumes \<open>register H\<close>
   assumes \<open>equivalent_registers F G\<close>
   shows \<open>equivalent_registers (H o F) (H o G)\<close>
   by (metis (no_types, lifting) assms(1) assms(2) comp_assoc equivalent_registers_def register_comp)
 
 subsection \<open>Compatibility simplification\<close>
 
 text \<open>The simproc \<open>compatibility_warn\<close> produces helpful warnings for subgoals of the form
    \<^term>\<open>compatible x y\<close> that are probably unsolvable due to missing declarations of 
    variable compatibility facts. Same for subgoals of the form \<^term>\<open>register x\<close>.\<close>
 simproc_setup "compatibility_warn" ("compatible x y" | "register x") = \<open>
 let val thy_string = Markup.markup (Theory.get_markup \<^theory>) (Context.theory_name \<^theory>)
 in
 fn m => fn ctxt => fn ct => let
   val (x,y) = case Thm.term_of ct of
                  Const(\<^const_name>\<open>compatible\<close>,_ ) $ x $ y => (x, SOME y)
                | Const(\<^const_name>\<open>register\<close>,_ ) $ x => (x, NONE)
   val str : string lazy = Lazy.lazy (fn () => Syntax.string_of_term ctxt (Thm.term_of ct))
   fun w msg = warning (msg ^ "\n(Disable these warnings with: using [[simproc del: "^thy_string^".compatibility_warn]])")
   val _ = case (x,y) of
         (Free(n,T), SOME (Free(n',T'))) => 
             if String.isPrefix ":" n orelse String.isPrefix ":" n' then 
                       w ("Simplification subgoal " ^ Lazy.force str ^ " contains a bound variable.\n" ^
                       "Try to add some assumptions that makes this goal solvable by the simplifier")
             else if n=n' then (if T=T' then () 
                           else w ("In simplification subgoal " ^ Lazy.force str ^ 
                                ", variables have same name and different types.\n" ^
                                "Probably something is wrong."))
                     else w ("Simplification subgoal " ^ Lazy.force str ^ 
                             " occurred but cannot be solved.\n" ^
                             "Please add assumption/fact  [simp]: \<open>" ^ Lazy.force str ^ 
                             "\<close>  somewhere.")
       | (Free(n,T), NONE) => 
             if String.isPrefix ":" n then 
                       w ("Simplification subgoal '" ^ Lazy.force str ^ "' contains a bound variable.\n" ^
                       "Try to add some assumptions that makes this goal solvable by the simplifier")
             else w ("Simplification subgoal " ^ Lazy.force str ^ " occurred but cannot be solved.\n" ^
                     "Please add assumption/fact  [simp]: \<open>" ^ Lazy.force str ^ "\<close>  somewhere.")
       | _ => ()
   in NONE end
 end\<close>
 
 
 named_theorems register_attribute_rule_immediate
 named_theorems register_attribute_rule
 
 lemmas [register_attribute_rule] = conjunct1 conjunct2 iso_register_is_register iso_register_is_register[OF iso_register_inv]
 lemmas [register_attribute_rule_immediate] = compatible_sym compatible_register1 compatible_register2
   asm_rl[of \<open>compatible _ _\<close>] asm_rl[of \<open>iso_register _\<close>] asm_rl[of \<open>register _\<close>] iso_register_inv
 
 text \<open>The following declares an attribute \<open>[register]\<close>. When the attribute is applied to a fact
   of the form \<^term>\<open>register F\<close>, \<^term>\<open>iso_register F\<close>, \<^term>\<open>compatible F G\<close> or a conjunction of these,
   then those facts are added to the simplifier together with some derived theorems
   (e.g., \<^term>\<open>compatible F G\<close> also adds \<^term>\<open>register F\<close>).
 
   In theory \<open>Laws_Complement\<close>, support for \<^term>\<open>is_unit_register F\<close> and \<^term>\<open>complements F G\<close> is
   added to this attribute.\<close>
 
 setup \<open>
 let
 fun add thm results = 
   Net.insert_term (K true) (Thm.concl_of thm, thm) results
   handle Net.INSERT => results
 fun try_rule f thm rule state = case SOME (rule OF [thm]) handle THM _ => NONE  of
   NONE => state | SOME th => f th state
 fun collect (rules,rules_immediate) thm results =
   results |> fold (try_rule add thm) rules_immediate |> fold (try_rule (collect (rules,rules_immediate)) thm) rules
 fun declare thm context = let
   val ctxt = Context.proof_of context
   val rules = Named_Theorems.get ctxt @{named_theorems register_attribute_rule}
   val rules_immediate = Named_Theorems.get ctxt @{named_theorems register_attribute_rule_immediate}
   val thms = collect (rules,rules_immediate) thm Net.empty |> Net.entries
   (* val _ = \<^print> thms *)
   in Simplifier.map_ss (fn ctxt => ctxt addsimps thms) context end
 in
 Attrib.setup \<^binding>\<open>register\<close>
  (Scan.succeed (Thm.declaration_attribute declare))
   "Add register-related rules to the simplifier"
 end
 \<close>
 
 subsection \<open>Notation\<close>
 
 no_notation comp_update (infixl "*\<^sub>u" 55)
 no_notation tensor_update (infixr "\<otimes>\<^sub>u" 70)
 
 bundle register_notation begin
 notation register_tensor (infixr "\<otimes>\<^sub>r" 70)
 notation register_pair ("'(_;_')")
 end
 
 bundle no_register_notation begin
 no_notation register_tensor (infixr "\<otimes>\<^sub>r" 70)
 no_notation register_pair ("'(_;_')")
 end
 
 end
diff --git a/thys/Registers/Laws_Classical.thy b/thys/Registers/Laws_Classical.thy
--- a/thys/Registers/Laws_Classical.thy
+++ b/thys/Registers/Laws_Classical.thy
@@ -1,819 +1,819 @@
 (*
  * This is an autogenerated file. Do not edit.
  * The original is Laws.thy. It was converted using instantiate_laws.py.
  *)
 
 section \<open>Generic laws about registers, instantiated classically\<close>
 
 theory Laws_Classical
   imports Axioms_Classical
 begin
 
 text \<open>This notation is only used inside this file\<close>
 notation map_comp (infixl "*\<^sub>u" 55)
 notation tensor_update (infixr "\<otimes>\<^sub>u" 70)
 notation register_pair ("'(_;_')")
 
 subsection \<open>Elementary facts\<close>
 
 declare id_preregister[simp]
 declare id_update_left[simp]
 declare id_update_right[simp]
 declare register_preregister[simp]
 declare register_comp[simp]
 declare register_of_id[simp]
 declare register_tensor_left[simp]
 declare register_tensor_right[simp]
 declare preregister_mult_right[simp]
 declare preregister_mult_left[simp]
 declare register_id[simp]
 
 subsection \<open>Preregisters\<close>
 
 lemma preregister_tensor_left[simp]: \<open>preregister (\<lambda>b::'b::type update. tensor_update a b)\<close>
   for a :: \<open>'a::type update\<close>
 proof -
   have \<open>preregister ((\<lambda>b1::('a\<times>'b) update. (a \<otimes>\<^sub>u Some) *\<^sub>u b1) o (\<lambda>b. tensor_update Some b))\<close>
     by (rule comp_preregister; simp)
   then show ?thesis
     by (simp add: o_def tensor_update_mult)
 qed
 
 lemma preregister_tensor_right[simp]: \<open>preregister (\<lambda>a::'a::type update. tensor_update a b)\<close>  
   for b :: \<open>'b::type update\<close>
 proof -
   have \<open>preregister ((\<lambda>a1::('a\<times>'b) update. (Some \<otimes>\<^sub>u b) *\<^sub>u a1) o (\<lambda>a. tensor_update a Some))\<close>
     by (rule comp_preregister, simp_all)
   then show ?thesis
     by (simp add: o_def tensor_update_mult)
 qed
 
 subsection \<open>Registers\<close>
 
 lemma id_update_tensor_register[simp]:
   assumes \<open>register F\<close>
   shows \<open>register (\<lambda>a::'a::type update. Some \<otimes>\<^sub>u F a)\<close>
   using assms apply (rule register_comp[unfolded o_def])
   by simp
 
 lemma register_tensor_id_update[simp]:
   assumes \<open>register F\<close>
   shows \<open>register (\<lambda>a::'a::type update. F a \<otimes>\<^sub>u Some)\<close>
   using assms apply (rule register_comp[unfolded o_def])
   by simp
 
 subsection \<open>Tensor product of registers\<close>
 
 definition register_tensor  (infixr "\<otimes>\<^sub>r" 70) where
   "register_tensor F G = register_pair (\<lambda>a. tensor_update (F a) Some) (\<lambda>b. tensor_update Some (G b))"
 
 lemma register_tensor_is_register: 
   fixes F :: "'a::type update \<Rightarrow> 'b::type update" and G :: "'c::type update \<Rightarrow> 'd::type update"
   shows "register F \<Longrightarrow> register G \<Longrightarrow> register (F \<otimes>\<^sub>r G)"
   unfolding register_tensor_def
   apply (rule register_pair_is_register)
   by (simp_all add: tensor_update_mult)
 
 lemma register_tensor_apply[simp]:
   fixes F :: "'a::type update \<Rightarrow> 'b::type update" and G :: "'c::type update \<Rightarrow> 'd::type update"
   assumes \<open>register F\<close> and \<open>register G\<close>
   shows "(F \<otimes>\<^sub>r G) (a \<otimes>\<^sub>u b) = F a \<otimes>\<^sub>u G b"
   unfolding register_tensor_def
   apply (subst register_pair_apply)
   unfolding register_tensor_def 
   by (simp_all add: assms tensor_update_mult)
 
 definition "separating (_::'b::type itself) A \<longleftrightarrow> 
   (\<forall>F G :: 'a::type update \<Rightarrow> 'b update. preregister F \<longrightarrow> preregister G \<longrightarrow> (\<forall>x\<in>A. F x = G x) \<longrightarrow> F = G)"
 
 lemma separating_UNIV[simp]: \<open>separating TYPE(_) UNIV\<close>
   unfolding separating_def by auto
 
 lemma separating_mono: \<open>A \<subseteq> B \<Longrightarrow> separating TYPE('a::type) A \<Longrightarrow> separating TYPE('a) B\<close>
   unfolding separating_def by (meson in_mono) 
 
 lemma register_eqI: \<open>separating TYPE('b::type) A \<Longrightarrow> preregister F \<Longrightarrow> preregister G \<Longrightarrow> (\<And>x. x\<in>A \<Longrightarrow> F x = G x) \<Longrightarrow> F = (G::_ \<Rightarrow> 'b update)\<close>
   unfolding separating_def by auto
 
 lemma separating_tensor:
   fixes A :: \<open>'a::type update set\<close> and B :: \<open>'b::type update set\<close>
   assumes [simp]: \<open>separating TYPE('c::type) A\<close>
   assumes [simp]: \<open>separating TYPE('c) B\<close>
   shows \<open>separating TYPE('c) {a \<otimes>\<^sub>u b | a b. a\<in>A \<and> b\<in>B}\<close>
 proof (unfold separating_def, intro allI impI)
   fix F G :: \<open>('a\<times>'b) update \<Rightarrow> 'c update\<close>
   assume [simp]: \<open>preregister F\<close> \<open>preregister G\<close>
   have [simp]: \<open>preregister (\<lambda>x. F (a \<otimes>\<^sub>u x))\<close> for a
     using _ \<open>preregister F\<close> apply (rule comp_preregister[unfolded o_def])
     by simp
   have [simp]: \<open>preregister (\<lambda>x. G (a \<otimes>\<^sub>u x))\<close> for a
     using _ \<open>preregister G\<close> apply (rule comp_preregister[unfolded o_def])
     by simp
   have [simp]: \<open>preregister (\<lambda>x. F (x \<otimes>\<^sub>u b))\<close> for b
     using _ \<open>preregister F\<close> apply (rule comp_preregister[unfolded o_def])
     by simp
   have [simp]: \<open>preregister (\<lambda>x. G (x \<otimes>\<^sub>u b))\<close> for b
     using _ \<open>preregister G\<close> apply (rule comp_preregister[unfolded o_def])
     by simp
 
   assume \<open>\<forall>x\<in>{a \<otimes>\<^sub>u b |a b. a\<in>A \<and> b\<in>B}. F x = G x\<close>
   then have EQ: \<open>F (a \<otimes>\<^sub>u b) = G (a \<otimes>\<^sub>u b)\<close> if \<open>a \<in> A\<close> and \<open>b \<in> B\<close> for a b
     using that by auto
   then have \<open>F (a \<otimes>\<^sub>u b) = G (a \<otimes>\<^sub>u b)\<close> if \<open>a \<in> A\<close> for a b
     apply (rule register_eqI[where A=B, THEN fun_cong, where x=b, rotated -1])
     using that by auto
   then have \<open>F (a \<otimes>\<^sub>u b) = G (a \<otimes>\<^sub>u b)\<close> for a b
     apply (rule register_eqI[where A=A, THEN fun_cong, where x=a, rotated -1])
     by auto
   then show "F = G"
     apply (rule tensor_extensionality[rotated -1])
     by auto
 qed
 
 lemma register_tensor_distrib:
   assumes [simp]: \<open>register F\<close> \<open>register G\<close> \<open>register H\<close> \<open>register L\<close>
   shows \<open>(F \<otimes>\<^sub>r G) o (H \<otimes>\<^sub>r L) = (F o H) \<otimes>\<^sub>r (G o L)\<close>
   apply (rule tensor_extensionality)
   by (auto intro!: register_comp register_preregister register_tensor_is_register)
 
 text \<open>The following is easier to apply using the @{method rule}-method than @{thm [source] separating_tensor}\<close>
 lemma separating_tensor':
   fixes A :: \<open>'a::type update set\<close> and B :: \<open>'b::type update set\<close>
   assumes \<open>separating TYPE('c::type) A\<close>
   assumes \<open>separating TYPE('c) B\<close>
   assumes \<open>C = {a \<otimes>\<^sub>u b | a b. a\<in>A \<and> b\<in>B}\<close>
   shows \<open>separating TYPE('c) C\<close>
   using assms
   by (simp add: separating_tensor)
 
 lemma tensor_extensionality3: 
   fixes F G :: \<open>('a::type\<times>'b::type\<times>'c::type) update \<Rightarrow> 'd::type update\<close>
   assumes [simp]: \<open>register F\<close> \<open>register G\<close>
   assumes "\<And>f g h. F (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h) = G (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h)"
   shows "F = G"
 proof (rule register_eqI[where A=\<open>{a\<otimes>\<^sub>ub\<otimes>\<^sub>uc| a b c. True}\<close>])
   have \<open>separating TYPE('d) {b \<otimes>\<^sub>u c |b c. True}\<close>
     apply (rule separating_tensor'[where A=UNIV and B=UNIV])
     by auto
   then show \<open>separating TYPE('d) {a \<otimes>\<^sub>u b \<otimes>\<^sub>u c |a b c. True}\<close>
     apply (rule_tac separating_tensor'[where A=UNIV and B=\<open>{b\<otimes>\<^sub>uc| b c. True}\<close>])
     by auto
   show \<open>preregister F\<close> \<open>preregister G\<close> by auto
   show \<open>x \<in> {a \<otimes>\<^sub>u b \<otimes>\<^sub>u c |a b c. True} \<Longrightarrow> F x = G x\<close> for x
     using assms(3) by auto
 qed
 
 lemma tensor_extensionality3': 
   fixes F G :: \<open>(('a::type\<times>'b::type)\<times>'c::type) update \<Rightarrow> 'd::type update\<close>
   assumes [simp]: \<open>register F\<close> \<open>register G\<close>
   assumes "\<And>f g h. F ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h) = G ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h)"
   shows "F = G"
 proof (rule register_eqI[where A=\<open>{(a\<otimes>\<^sub>ub)\<otimes>\<^sub>uc| a b c. True}\<close>])
   have \<open>separating TYPE('d) {a \<otimes>\<^sub>u b | a b. True}\<close>
     apply (rule separating_tensor'[where A=UNIV and B=UNIV])
     by auto
   then show \<open>separating TYPE('d) {(a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c |a b c. True}\<close>
     apply (rule_tac separating_tensor'[where B=UNIV and A=\<open>{a\<otimes>\<^sub>ub| a b. True}\<close>])
     by auto
   show \<open>preregister F\<close> \<open>preregister G\<close> by auto
   show \<open>x \<in> {(a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c |a b c. True} \<Longrightarrow> F x = G x\<close> for x
     using assms(3) by auto
 qed
 
 lemma register_tensor_id[simp]: \<open>id \<otimes>\<^sub>r id = id\<close>
   apply (rule tensor_extensionality)
   by (auto simp add: register_tensor_is_register)
 
 subsection \<open>Pairs and compatibility\<close>
 
 definition compatible :: \<open>('a::type update \<Rightarrow> 'c::type update)
                        \<Rightarrow> ('b::type update \<Rightarrow> 'c update) \<Rightarrow> bool\<close> where
   \<open>compatible F G \<longleftrightarrow> register F \<and> register G \<and> (\<forall>a b. F a *\<^sub>u G b = G b *\<^sub>u F a)\<close>
 
 lemma compatibleI:
   assumes "register F" and "register G"
   assumes \<open>\<And>a b. (F a) *\<^sub>u (G b) = (G b) *\<^sub>u (F a)\<close>
   shows "compatible F G"
   using assms unfolding compatible_def by simp
 
 lemma swap_registers:
   assumes "compatible R S"
   shows "R a *\<^sub>u S b = S b *\<^sub>u R a"
   using assms unfolding compatible_def by metis
 
 lemma compatible_sym: "compatible x y \<Longrightarrow> compatible y x"
   by (simp add: compatible_def)
 
 lemma pair_is_register[simp]:
   assumes "compatible F G"
   shows "register (F; G)"
   by (metis assms compatible_def register_pair_is_register)
 
 lemma register_pair_apply:
   assumes \<open>compatible F G\<close>
   shows \<open>(F; G) (a \<otimes>\<^sub>u b) = (F a) *\<^sub>u (G b)\<close>
   apply (rule register_pair_apply)
   using assms unfolding compatible_def by metis+
 
 lemma register_pair_apply':
   assumes \<open>compatible F G\<close>
   shows \<open>(F; G) (a \<otimes>\<^sub>u b) = (G b) *\<^sub>u (F a)\<close>
   apply (subst register_pair_apply)
   using assms by (auto simp: compatible_def intro: register_preregister)
 
 
 
 lemma compatible_comp_left[simp]: "compatible F G \<Longrightarrow> register H \<Longrightarrow> compatible (F \<circ> H) G"
   by (simp add: compatible_def)
 
 lemma compatible_comp_right[simp]: "compatible F G \<Longrightarrow> register H \<Longrightarrow> compatible F (G \<circ> H)"
   by (simp add: compatible_def)
 
 lemma compatible_comp_inner[simp]: 
   "compatible F G \<Longrightarrow> register H \<Longrightarrow> compatible (H \<circ> F) (H \<circ> G)"
   by (smt (verit, best) comp_apply compatible_def register_comp register_mult)
 
 lemma compatible_register1: \<open>compatible F G \<Longrightarrow> register F\<close>
   by (simp add: compatible_def)
 lemma compatible_register2: \<open>compatible F G \<Longrightarrow> register G\<close>
   by (simp add: compatible_def)
 
 lemma pair_o_tensor:
   assumes "compatible A B" and [simp]: \<open>register C\<close> and [simp]: \<open>register D\<close>
   shows "(A; B) o (C \<otimes>\<^sub>r D) = (A o C; B o D)"
   apply (rule tensor_extensionality)
   using assms by (simp_all add: register_tensor_is_register register_pair_apply comp_preregister)
 
 lemma compatible_tensor_id_update_left[simp]:
   fixes F :: "'a::type update \<Rightarrow> 'c::type update" and G :: "'b::type update \<Rightarrow> 'c::type update"
   assumes "compatible F G"
   shows "compatible (\<lambda>a. Some \<otimes>\<^sub>u F a) (\<lambda>a. Some \<otimes>\<^sub>u G a)"
   using assms apply (rule compatible_comp_inner[unfolded o_def])
   by simp
 
 lemma compatible_tensor_id_update_right[simp]:
   fixes F :: "'a::type update \<Rightarrow> 'c::type update" and G :: "'b::type update \<Rightarrow> 'c::type update"
   assumes "compatible F G"
   shows "compatible (\<lambda>a. F a \<otimes>\<^sub>u Some) (\<lambda>a. G a \<otimes>\<^sub>u Some)"
   using assms apply (rule compatible_comp_inner[unfolded o_def])
   by simp
 
 lemma compatible_tensor_id_update_rl[simp]:
   assumes "register F" and "register G"
   shows "compatible (\<lambda>a. F a \<otimes>\<^sub>u Some) (\<lambda>a. Some \<otimes>\<^sub>u G a)"
   apply (rule compatibleI)
   using assms by (auto simp: tensor_update_mult)
 
 lemma compatible_tensor_id_update_lr[simp]:
   assumes "register F" and "register G"
   shows "compatible (\<lambda>a. Some \<otimes>\<^sub>u F a) (\<lambda>a. G a \<otimes>\<^sub>u Some)"
   apply (rule compatibleI)
   using assms by (auto simp: tensor_update_mult)
 
 lemma register_comp_pair:
   assumes [simp]: \<open>register F\<close> and [simp]: \<open>compatible G H\<close>
   shows "(F o G; F o H) = F o (G; H)"
 proof (rule tensor_extensionality)
   show \<open>preregister (F \<circ> G;F \<circ> H)\<close> and \<open>preregister (F \<circ> (G;H))\<close>
     by simp_all
 
   have [simp]: \<open>compatible (F o G) (F o H)\<close>
     apply (rule compatible_comp_inner, simp)
     by simp
   then have [simp]: \<open>register (F \<circ> G)\<close> \<open>register (F \<circ> H)\<close>
     unfolding compatible_def by auto
   from assms have [simp]: \<open>register G\<close> \<open>register H\<close>
     unfolding compatible_def by auto
   fix a b
   show \<open>(F \<circ> G;F \<circ> H) (a \<otimes>\<^sub>u b) = (F \<circ> (G;H)) (a \<otimes>\<^sub>u b)\<close>
     by (auto simp: register_pair_apply register_mult tensor_update_mult)
 qed
 
 lemma swap_registers_left:
   assumes "compatible R S"
   shows "R a *\<^sub>u S b *\<^sub>u c = S b *\<^sub>u R a *\<^sub>u c"
   using assms unfolding compatible_def by metis
 
 lemma swap_registers_right:
   assumes "compatible R S"
   shows "c *\<^sub>u R a *\<^sub>u S b = c *\<^sub>u S b *\<^sub>u R a"
   by (metis assms comp_update_assoc compatible_def)
 
 lemmas compatible_ac_rules = swap_registers comp_update_assoc[symmetric] swap_registers_right
 
 subsection \<open>Fst and Snd\<close>
 
 definition Fst where \<open>Fst a = a \<otimes>\<^sub>u Some\<close>
 definition Snd where \<open>Snd a = Some \<otimes>\<^sub>u a\<close>
 
 lemma register_Fst[simp]: \<open>register Fst\<close>
   unfolding Fst_def by (rule register_tensor_left)
 
 lemma register_Snd[simp]: \<open>register Snd\<close>
   unfolding Snd_def by (rule register_tensor_right)
 
 lemma compatible_Fst_Snd[simp]: \<open>compatible Fst Snd\<close>
   apply (rule compatibleI, simp, simp)
   by (simp add: Fst_def Snd_def tensor_update_mult)
 
 lemmas compatible_Snd_Fst[simp] = compatible_Fst_Snd[THEN compatible_sym]
 
 definition \<open>swap = (Snd; Fst)\<close>
 
 lemma swap_apply[simp]: "swap (a \<otimes>\<^sub>u b) = (b \<otimes>\<^sub>u a)"
   unfolding swap_def
   by (simp add: Axioms_Classical.register_pair_apply Fst_def Snd_def tensor_update_mult) 
 
 lemma swap_o_Fst: "swap o Fst = Snd"
   by (auto simp add: Fst_def Snd_def)
 lemma swap_o_Snd: "swap o Snd = Fst"
   by (auto simp add: Fst_def Snd_def)
 
 lemma register_swap[simp]: \<open>register swap\<close>
   by (simp add: swap_def)
 
 lemma pair_Fst_Snd: \<open>(Fst; Snd) = id\<close>
   apply (rule tensor_extensionality)
   by (simp_all add: register_pair_apply Fst_def Snd_def tensor_update_mult)
 
 lemma swap_o_swap[simp]: \<open>swap o swap = id\<close>
   by (metis swap_def compatible_Snd_Fst pair_Fst_Snd register_comp_pair register_swap swap_o_Fst swap_o_Snd)
 
 lemma swap_swap[simp]: \<open>swap (swap x) = x\<close>
   by (simp add: pointfree_idE)
 
 lemma inv_swap[simp]: \<open>inv swap = swap\<close>
   by (meson inv_unique_comp swap_o_swap)
 
 lemma register_pair_Fst:
   assumes \<open>compatible F G\<close>
   shows \<open>(F;G) o Fst = F\<close>
   using assms by (auto intro!: ext simp: Fst_def register_pair_apply compatible_register2)
 
 lemma register_pair_Snd:
   assumes \<open>compatible F G\<close>
   shows \<open>(F;G) o Snd = G\<close>
   using assms by (auto intro!: ext simp: Snd_def register_pair_apply compatible_register1)
 
 lemma register_Fst_register_Snd[simp]:
   assumes \<open>register F\<close>
   shows \<open>(F o Fst; F o Snd) = F\<close>
   apply (rule tensor_extensionality)
   using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult tensor_update_mult)
 
 lemma register_Snd_register_Fst[simp]: 
   assumes \<open>register F\<close>
   shows \<open>(F o Snd; F o Fst) = F o swap\<close>
   apply (rule tensor_extensionality)
   using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult tensor_update_mult)
 
 
 lemma compatible3[simp]:
   assumes [simp]: "compatible F G" and "compatible G H" and "compatible F H"
   shows "compatible (F; G) H"
 proof (rule compatibleI)
   have [simp]: \<open>register F\<close> \<open>register G\<close> \<open>register H\<close>
     using assms compatible_def by auto
   then have [simp]: \<open>preregister F\<close> \<open>preregister G\<close> \<open>preregister H\<close>
     using register_preregister by blast+
   have [simp]: \<open>preregister (\<lambda>a. (F;G) a *\<^sub>u z)\<close> for z
     apply (rule comp_preregister[unfolded o_def, of \<open>(F;G)\<close>])
     by simp_all
   have [simp]: \<open>preregister (\<lambda>a. z *\<^sub>u (F;G) a)\<close> for z
     apply (rule comp_preregister[unfolded o_def, of \<open>(F;G)\<close>])
     by simp_all
   have "(F; G) (f \<otimes>\<^sub>u g) *\<^sub>u H h = H h *\<^sub>u (F; G) (f \<otimes>\<^sub>u g)" for f g h
   proof -
     have FH: "F f *\<^sub>u H h = H h *\<^sub>u F f"
       using assms compatible_def by metis
     have GH: "G g *\<^sub>u H h = H h *\<^sub>u G g"
       using assms compatible_def by metis
     have \<open>(F; G) (f \<otimes>\<^sub>u g) *\<^sub>u (H h) = F f *\<^sub>u G g *\<^sub>u H h\<close>
       using \<open>compatible F G\<close> by (subst register_pair_apply, auto)
     also have \<open>\<dots> = H h *\<^sub>u F f *\<^sub>u G g\<close>
       using FH GH by (metis comp_update_assoc)
     also have \<open>\<dots> = H h *\<^sub>u (F; G) (f \<otimes>\<^sub>u g)\<close>
       using \<open>compatible F G\<close> by (subst register_pair_apply, auto simp: comp_update_assoc)
     finally show ?thesis
       by -
   qed
   then show "(F; G) fg *\<^sub>u (H h) = (H h) *\<^sub>u (F; G) fg" for fg h
     apply (rule_tac tensor_extensionality[THEN fun_cong])
     by auto
   show "register H" and  "register (F; G)"
     by simp_all
 qed
 
 lemma compatible3'[simp]:
   assumes "compatible F G" and "compatible G H" and "compatible F H"
   shows "compatible F (G; H)"
   apply (rule compatible_sym)
   apply (rule compatible3)
   using assms by (auto simp: compatible_sym)
 
 lemma pair_o_swap[simp]:
   assumes [simp]: "compatible A B"
   shows "(A; B) o swap = (B; A)"
 proof (rule tensor_extensionality)
   have [simp]: "preregister A" "preregister B"
-     apply (metis (no_types, hide_lams) assms compatible_register1 register_preregister)
+     apply (metis (no_types, opaque_lifting) assms compatible_register1 register_preregister)
     by (metis (full_types) assms compatible_register2 register_preregister)
   then show \<open>preregister ((A; B) \<circ> swap)\<close>
     by simp
   show \<open>preregister (B; A)\<close>
     by (metis (no_types, lifting) assms compatible_sym register_preregister pair_is_register)
   show \<open>((A; B) \<circ> swap) (a \<otimes>\<^sub>u b) = (B; A) (a \<otimes>\<^sub>u b)\<close> for a b
     (* Without the "only:", we would not need the "apply subst",
        but that proof fails when instantiated in Classical.thy *)
     apply (simp only: o_def swap_apply)
     apply (subst register_pair_apply, simp)
     apply (subst register_pair_apply, simp add: compatible_sym)
     by (metis (no_types, lifting) assms compatible_def)
 qed
 
 
 subsection \<open>Compatibility of register tensor products\<close>
 
 lemma compatible_register_tensor:
   fixes F :: \<open>'a::type update \<Rightarrow> 'e::type update\<close> and G :: \<open>'b::type update \<Rightarrow> 'f::type update\<close>
     and F' :: \<open>'c::type update \<Rightarrow> 'e update\<close> and G' :: \<open>'d::type update \<Rightarrow> 'f update\<close>
   assumes [simp]: \<open>compatible F F'\<close>
   assumes [simp]: \<open>compatible G G'\<close>
   shows \<open>compatible (F \<otimes>\<^sub>r G) (F' \<otimes>\<^sub>r G')\<close>
 proof -
   note [intro!] = 
     comp_preregister[OF _ preregister_mult_right, unfolded o_def]
     comp_preregister[OF _ preregister_mult_left, unfolded o_def]
     comp_preregister
     register_tensor_is_register
   have [simp]: \<open>register F\<close> \<open>register G\<close> \<open>register F'\<close> \<open>register G'\<close>
     using assms compatible_def by blast+
   have [simp]: \<open>register (F \<otimes>\<^sub>r G)\<close> \<open>register (F' \<otimes>\<^sub>r G')\<close>
     by (auto simp add: register_tensor_def)
   have [simp]: \<open>register (F;F')\<close> \<open>register (G;G')\<close>
     by auto
   define reorder :: \<open>(('a\<times>'b) \<times> ('c\<times>'d)) update \<Rightarrow> (('a\<times>'c) \<times> ('b\<times>'d)) update\<close>
     where \<open>reorder = ((Fst o Fst; Snd o Fst); (Fst o Snd; Snd o Snd))\<close>
   have [simp]: \<open>preregister reorder\<close>
     by (auto simp: reorder_def)
   have [simp]: \<open>reorder ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u (c \<otimes>\<^sub>u d)) = ((a \<otimes>\<^sub>u c) \<otimes>\<^sub>u (b \<otimes>\<^sub>u d))\<close> for a b c d
     apply (simp add: reorder_def register_pair_apply)
     by (simp add: Fst_def Snd_def tensor_update_mult)
   define \<Phi> where \<open>\<Phi> c d = ((F;F') \<otimes>\<^sub>r (G;G')) o reorder o (\<lambda>\<sigma>. \<sigma> \<otimes>\<^sub>u (c \<otimes>\<^sub>u d))\<close> for c d
   have [simp]: \<open>preregister (\<Phi> c d)\<close> for c d
     unfolding \<Phi>_def 
     by (auto intro: register_preregister)
   have \<open>\<Phi> c d (a \<otimes>\<^sub>u b) = (F \<otimes>\<^sub>r G) (a \<otimes>\<^sub>u b) *\<^sub>u (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d)\<close> for a b c d
     unfolding \<Phi>_def by (auto simp: register_pair_apply tensor_update_mult)
   then have \<Phi>1: \<open>\<Phi> c d \<sigma> = (F \<otimes>\<^sub>r G) \<sigma> *\<^sub>u (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d)\<close> for c d \<sigma>
     apply (rule_tac fun_cong[of _ _ \<sigma>])
     apply (rule tensor_extensionality)
     by auto
   have \<open>\<Phi> c d (a \<otimes>\<^sub>u b) = (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d) *\<^sub>u (F \<otimes>\<^sub>r G) (a \<otimes>\<^sub>u b)\<close> for a b c d
     unfolding \<Phi>_def apply (auto simp: register_pair_apply)
     by (metis assms(1) assms(2) compatible_def tensor_update_mult)
   then have \<Phi>2: \<open>\<Phi> c d \<sigma> = (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d) *\<^sub>u (F \<otimes>\<^sub>r G) \<sigma>\<close> for c d \<sigma>
     apply (rule_tac fun_cong[of _ _ \<sigma>])
     apply (rule tensor_extensionality)
     by auto
   from \<Phi>1 \<Phi>2 have \<open>(F \<otimes>\<^sub>r G) \<sigma> *\<^sub>u (F' \<otimes>\<^sub>r G') \<tau> = (F' \<otimes>\<^sub>r G') \<tau> *\<^sub>u (F \<otimes>\<^sub>r G) \<sigma>\<close> for \<tau> \<sigma>
     apply (rule_tac fun_cong[of _ _ \<tau>])
     apply (rule tensor_extensionality)
     by auto
   then show ?thesis
     apply (rule compatibleI[rotated -1])
     by auto
 qed
 
 subsection \<open>Associativity of the tensor product\<close>
 
 definition assoc :: \<open>(('a::type\<times>'b::type)\<times>'c::type) update \<Rightarrow> ('a\<times>('b\<times>'c)) update\<close> where 
   \<open>assoc = ((Fst; Snd o Fst); Snd o Snd)\<close>
 
 lemma assoc_is_hom[simp]: \<open>preregister assoc\<close>
   by (auto simp: assoc_def)
 
 lemma assoc_apply[simp]: \<open>assoc ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c) = (a \<otimes>\<^sub>u (b \<otimes>\<^sub>u c))\<close>
   by (auto simp: assoc_def register_pair_apply Fst_def Snd_def tensor_update_mult)
 
 definition assoc' :: \<open>('a\<times>('b\<times>'c)) update \<Rightarrow> (('a::type\<times>'b::type)\<times>'c::type) update\<close> where 
   \<open>assoc' = (Fst o Fst; (Fst o Snd; Snd))\<close>
 
 lemma assoc'_is_hom[simp]: \<open>preregister assoc'\<close>
   by (auto simp: assoc'_def)
 
 lemma assoc'_apply[simp]: \<open>assoc' (a \<otimes>\<^sub>u (b \<otimes>\<^sub>u c)) =  ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c)\<close>
   by (auto simp: assoc'_def register_pair_apply Fst_def Snd_def tensor_update_mult)
 
 lemma register_assoc[simp]: \<open>register assoc\<close>
   unfolding assoc_def
   by force
 
 lemma register_assoc'[simp]: \<open>register assoc'\<close>
   unfolding assoc'_def 
   by force
 
 lemma pair_o_assoc[simp]:
   assumes [simp]: \<open>compatible F G\<close> \<open>compatible G H\<close> \<open>compatible F H\<close>
   shows \<open>(F; (G; H)) \<circ> assoc = ((F; G); H)\<close>
 proof (rule tensor_extensionality3')
   show \<open>register ((F; (G; H)) \<circ> assoc)\<close>
     by simp
   show \<open>register ((F; G); H)\<close>
     by simp
   show \<open>((F; (G; H)) \<circ> assoc) ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h) = ((F; G); H) ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h)\<close> for f g h
     by (simp add: register_pair_apply assoc_apply comp_update_assoc)
 qed
 
 lemma pair_o_assoc'[simp]:
   assumes [simp]: \<open>compatible F G\<close> \<open>compatible G H\<close> \<open>compatible F H\<close>
   shows \<open>((F; G); H) \<circ> assoc' = (F; (G; H))\<close>
 proof (rule tensor_extensionality3)
   show \<open>register (((F; G); H) \<circ> assoc')\<close>
     by simp
   show \<open>register (F; (G; H))\<close>
     by simp
   show \<open>(((F; G); H) \<circ> assoc') (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h) = (F; (G; H)) (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h)\<close> for f g h
     by (simp add: register_pair_apply assoc'_apply comp_update_assoc)
 qed
 
 lemma assoc'_o_assoc[simp]: \<open>assoc' o assoc = id\<close>
   apply (rule tensor_extensionality3')
   by auto
 
 lemma assoc'_assoc[simp]: \<open>assoc' (assoc x) = x\<close>
   by (simp add: pointfree_idE)
 
 lemma assoc_o_assoc'[simp]: \<open>assoc o assoc' = id\<close>
   apply (rule tensor_extensionality3)
   by auto
 
 lemma assoc_assoc'[simp]: \<open>assoc (assoc' x) = x\<close>
   by (simp add: pointfree_idE)
 
 lemma inv_assoc[simp]: \<open>inv assoc = assoc'\<close>
   using assoc'_o_assoc assoc_o_assoc' inv_unique_comp by blast
 
 lemma inv_assoc'[simp]: \<open>inv assoc' = assoc\<close>
   by (simp add: inv_equality)
 
 lemma [simp]: \<open>bij assoc\<close>
   using assoc'_o_assoc assoc_o_assoc' o_bij by blast
 
 lemma [simp]: \<open>bij assoc'\<close>
   using assoc'_o_assoc assoc_o_assoc' o_bij by blast
 
 subsection \<open>Iso-registers\<close>
 
 definition \<open>iso_register F \<longleftrightarrow> register F \<and> (\<exists>G. register G \<and> F o G = id \<and> G o F = id)\<close>
   for F :: \<open>_::type update \<Rightarrow> _::type update\<close>
 
 lemma iso_registerI:
   assumes \<open>register F\<close> \<open>register G\<close> \<open>F o G = id\<close> \<open>G o F = id\<close>
   shows \<open>iso_register F\<close>
   using assms(1) assms(2) assms(3) assms(4) iso_register_def by blast
 
 lemma iso_register_inv: \<open>iso_register F \<Longrightarrow> iso_register (inv F)\<close>
   by (metis inv_unique_comp iso_register_def)
 
 lemma iso_register_inv_comp1: \<open>iso_register F \<Longrightarrow> inv F o F = id\<close>
   using inv_unique_comp iso_register_def by blast
 
 lemma iso_register_inv_comp2: \<open>iso_register F \<Longrightarrow> F o inv F = id\<close>
   using inv_unique_comp iso_register_def by blast
 
 
 lemma iso_register_id[simp]: \<open>iso_register id\<close>
   by (simp add: iso_register_def)
 
 lemma iso_register_is_register: \<open>iso_register F \<Longrightarrow> register F\<close>
   using iso_register_def by blast
 
 lemma iso_register_comp[simp]:
   assumes [simp]: \<open>iso_register F\<close> \<open>iso_register G\<close>
   shows \<open>iso_register (F o G)\<close>
 proof -
   from assms obtain F' G' where [simp]: \<open>register F'\<close> \<open>register G'\<close> \<open>F o F' = id\<close> \<open>F' o F = id\<close>
     \<open>G o G' = id\<close> \<open>G' o G = id\<close>
     by (meson iso_register_def)
   show ?thesis
     apply (rule iso_registerI[where G=\<open>G' o F'\<close>])
        apply (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
      apply (metis \<open>F \<circ> F' = id\<close> \<open>G \<circ> G' = id\<close> fcomp_assoc fcomp_comp id_fcomp)
     by (metis (no_types, lifting) \<open>F \<circ> F' = id\<close> \<open>F' \<circ> F = id\<close> \<open>G' \<circ> G = id\<close> fun.map_comp inj_iff inv_unique_comp o_inv_o_cancel)
 qed
 
 
 lemma iso_register_tensor_is_iso_register[simp]:
   assumes [simp]: \<open>iso_register F\<close> \<open>iso_register G\<close>
   shows \<open>iso_register (F \<otimes>\<^sub>r G)\<close>
 proof -
   from assms obtain F' G' where [simp]: \<open>register F'\<close> \<open>register G'\<close> \<open>F o F' = id\<close> \<open>F' o F = id\<close>
     \<open>G o G' = id\<close> \<open>G' o G = id\<close>
     by (meson iso_register_def)
   show ?thesis
     apply (rule iso_registerI[where G=\<open>F' \<otimes>\<^sub>r G'\<close>])
     by (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
 qed
 
 lemma iso_register_bij: \<open>iso_register F \<Longrightarrow> bij F\<close>
   using iso_register_def o_bij by auto
 
 lemma inv_register_tensor[simp]: 
   assumes [simp]: \<open>iso_register F\<close> \<open>iso_register G\<close>
   shows \<open>inv (F \<otimes>\<^sub>r G) = inv F \<otimes>\<^sub>r inv G\<close>
   apply (auto intro!: inj_imp_inv_eq bij_is_inj iso_register_bij 
               simp: register_tensor_distrib[unfolded o_def, THEN fun_cong] iso_register_is_register
                     iso_register_inv bij_is_surj iso_register_bij surj_f_inv_f)
   by (metis eq_id_iff register_tensor_id)
 
 lemma iso_register_swap[simp]: \<open>iso_register swap\<close>
   apply (rule iso_registerI[of _ swap])
   by auto
 
 lemma iso_register_assoc[simp]: \<open>iso_register assoc\<close>
   apply (rule iso_registerI[of _ assoc'])
   by auto
 
 lemma iso_register_assoc'[simp]: \<open>iso_register assoc'\<close>
   apply (rule iso_registerI[of _ assoc])
   by auto
 
 definition \<open>equivalent_registers F G \<longleftrightarrow> (register F \<and> (\<exists>I. iso_register I \<and> F o I = G))\<close>
   for F G :: \<open>_::type update \<Rightarrow> _::type update\<close>
 
 lemma iso_register_equivalent_id[simp]: \<open>equivalent_registers id F \<longleftrightarrow> iso_register F\<close>
   by (simp add: equivalent_registers_def)
 
 lemma equivalent_registersI:
   assumes \<open>register F\<close>
   assumes \<open>iso_register I\<close>
   assumes \<open>F o I = G\<close>
   shows \<open>equivalent_registers F G\<close>
   using assms unfolding equivalent_registers_def by blast
 
 lemma equivalent_registers_register_left: \<open>equivalent_registers F G \<Longrightarrow> register F\<close>
   using equivalent_registers_def by auto
 
 lemma equivalent_registers_register_right: \<open>register G\<close> if \<open>equivalent_registers F G\<close>
   by (metis equivalent_registers_def iso_register_def register_comp that)
 
 lemma equivalent_registers_sym:
   assumes \<open>equivalent_registers F G\<close>
   shows \<open>equivalent_registers G F\<close>
   by (smt (verit) assms comp_id equivalent_registers_def equivalent_registers_register_right fun.map_comp iso_register_def)
 
 lemma equivalent_registers_trans[trans]: 
   assumes \<open>equivalent_registers F G\<close> and \<open>equivalent_registers G H\<close>
   shows \<open>equivalent_registers F H\<close>
 proof -
   from assms have [simp]: \<open>register F\<close> \<open>register G\<close>
     by (auto simp: equivalent_registers_def)
   from assms(1) obtain I where [simp]: \<open>iso_register I\<close> and \<open>F o I = G\<close>
     using equivalent_registers_def by blast
   from assms(2) obtain J where [simp]: \<open>iso_register J\<close> and \<open>G o J = H\<close>
     using equivalent_registers_def by blast
   have \<open>register F\<close>
     by (auto simp: equivalent_registers_def)
   moreover have \<open>iso_register (I o J)\<close>
     using \<open>iso_register I\<close> \<open>iso_register J\<close> iso_register_comp by blast
   moreover have \<open>F o (I o J) = H\<close>
     by (simp add: \<open>F \<circ> I = G\<close> \<open>G \<circ> J = H\<close> o_assoc)
   ultimately show ?thesis
     by (rule equivalent_registersI)
 qed
 
 lemma equivalent_registers_assoc[simp]:
   assumes [simp]: \<open>compatible F G\<close> \<open>compatible F H\<close> \<open>compatible G H\<close>
   shows \<open>equivalent_registers (F;(G;H)) ((F;G);H)\<close>
   apply (rule equivalent_registersI[where I=assoc])
   by auto
 
 lemma equivalent_registers_pair_right:
   assumes [simp]: \<open>compatible F G\<close>
   assumes eq: \<open>equivalent_registers G H\<close>
   shows \<open>equivalent_registers (F;G) (F;H)\<close>
 proof -
   from eq obtain I where [simp]: \<open>iso_register I\<close> and \<open>G o I = H\<close>
     by (metis equivalent_registers_def)
   then have *: \<open>(F;G) \<circ> (id \<otimes>\<^sub>r I) = (F;H)\<close>
     by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register 
         simp:  register_pair_apply iso_register_is_register)
   show ?thesis
     apply (rule equivalent_registersI[where I=\<open>id \<otimes>\<^sub>r I\<close>])
     using * by (auto intro!: iso_register_tensor_is_iso_register)
 qed
 
 lemma equivalent_registers_pair_left:
   assumes [simp]: \<open>compatible F G\<close>
   assumes eq: \<open>equivalent_registers F H\<close>
   shows \<open>equivalent_registers (F;G) (H;G)\<close>
 proof -
   from eq obtain I where [simp]: \<open>iso_register I\<close> and \<open>F o I = H\<close>
     by (metis equivalent_registers_def)
   then have *: \<open>(F;G) \<circ> (I \<otimes>\<^sub>r id) = (H;G)\<close>
     by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register 
         simp:  register_pair_apply iso_register_is_register)
   show ?thesis
     apply (rule equivalent_registersI[where I=\<open>I \<otimes>\<^sub>r id\<close>])
     using * by (auto intro!: iso_register_tensor_is_iso_register)
 qed
 
 lemma equivalent_registers_comp:
   assumes \<open>register H\<close>
   assumes \<open>equivalent_registers F G\<close>
   shows \<open>equivalent_registers (H o F) (H o G)\<close>
   by (metis (no_types, lifting) assms(1) assms(2) comp_assoc equivalent_registers_def register_comp)
 
 subsection \<open>Compatibility simplification\<close>
 
 text \<open>The simproc \<open>compatibility_warn\<close> produces helpful warnings for subgoals of the form
    \<^term>\<open>compatible x y\<close> that are probably unsolvable due to missing declarations of 
    variable compatibility facts. Same for subgoals of the form \<^term>\<open>register x\<close>.\<close>
 simproc_setup "compatibility_warn" ("compatible x y" | "register x") = \<open>
 let val thy_string = Markup.markup (Theory.get_markup \<^theory>) (Context.theory_name \<^theory>)
 in
 fn m => fn ctxt => fn ct => let
   val (x,y) = case Thm.term_of ct of
                  Const(\<^const_name>\<open>compatible\<close>,_ ) $ x $ y => (x, SOME y)
                | Const(\<^const_name>\<open>register\<close>,_ ) $ x => (x, NONE)
   val str : string lazy = Lazy.lazy (fn () => Syntax.string_of_term ctxt (Thm.term_of ct))
   fun w msg = warning (msg ^ "\n(Disable these warnings with: using [[simproc del: "^thy_string^".compatibility_warn]])")
   val _ = case (x,y) of
         (Free(n,T), SOME (Free(n',T'))) => 
             if String.isPrefix ":" n orelse String.isPrefix ":" n' then 
                       w ("Simplification subgoal " ^ Lazy.force str ^ " contains a bound variable.\n" ^
                       "Try to add some assumptions that makes this goal solvable by the simplifier")
             else if n=n' then (if T=T' then () 
                           else w ("In simplification subgoal " ^ Lazy.force str ^ 
                                ", variables have same name and different types.\n" ^
                                "Probably something is wrong."))
                     else w ("Simplification subgoal " ^ Lazy.force str ^ 
                             " occurred but cannot be solved.\n" ^
                             "Please add assumption/fact  [simp]: \<open>" ^ Lazy.force str ^ 
                             "\<close>  somewhere.")
       | (Free(n,T), NONE) => 
             if String.isPrefix ":" n then 
                       w ("Simplification subgoal '" ^ Lazy.force str ^ "' contains a bound variable.\n" ^
                       "Try to add some assumptions that makes this goal solvable by the simplifier")
             else w ("Simplification subgoal " ^ Lazy.force str ^ " occurred but cannot be solved.\n" ^
                     "Please add assumption/fact  [simp]: \<open>" ^ Lazy.force str ^ "\<close>  somewhere.")
       | _ => ()
   in NONE end
 end\<close>
 
 
 named_theorems register_attribute_rule_immediate
 named_theorems register_attribute_rule
 
 lemmas [register_attribute_rule] = conjunct1 conjunct2 iso_register_is_register iso_register_is_register[OF iso_register_inv]
 lemmas [register_attribute_rule_immediate] = compatible_sym compatible_register1 compatible_register2
   asm_rl[of \<open>compatible _ _\<close>] asm_rl[of \<open>iso_register _\<close>] asm_rl[of \<open>register _\<close>] iso_register_inv
 
 text \<open>The following declares an attribute \<open>[register]\<close>. When the attribute is applied to a fact
   of the form \<^term>\<open>register F\<close>, \<^term>\<open>iso_register F\<close>, \<^term>\<open>compatible F G\<close> or a conjunction of these,
   then those facts are added to the simplifier together with some derived theorems
   (e.g., \<^term>\<open>compatible F G\<close> also adds \<^term>\<open>register F\<close>).
 
   In theory \<open>Laws_Complement\<close>, support for \<^term>\<open>is_unit_register F\<close> and \<^term>\<open>complements F G\<close> is
   added to this attribute.\<close>
 
 setup \<open>
 let
 fun add thm results = 
   Net.insert_term (K true) (Thm.concl_of thm, thm) results
   handle Net.INSERT => results
 fun try_rule f thm rule state = case SOME (rule OF [thm]) handle THM _ => NONE  of
   NONE => state | SOME th => f th state
 fun collect (rules,rules_immediate) thm results =
   results |> fold (try_rule add thm) rules_immediate |> fold (try_rule (collect (rules,rules_immediate)) thm) rules
 fun declare thm context = let
   val ctxt = Context.proof_of context
   val rules = Named_Theorems.get ctxt @{named_theorems register_attribute_rule}
   val rules_immediate = Named_Theorems.get ctxt @{named_theorems register_attribute_rule_immediate}
   val thms = collect (rules,rules_immediate) thm Net.empty |> Net.entries
   (* val _ = \<^print> thms *)
   in Simplifier.map_ss (fn ctxt => ctxt addsimps thms) context end
 in
 Attrib.setup \<^binding>\<open>register\<close>
  (Scan.succeed (Thm.declaration_attribute declare))
   "Add register-related rules to the simplifier"
 end
 \<close>
 
 subsection \<open>Notation\<close>
 
 no_notation map_comp (infixl "*\<^sub>u" 55)
 no_notation tensor_update (infixr "\<otimes>\<^sub>u" 70)
 
 bundle register_notation begin
 notation register_tensor (infixr "\<otimes>\<^sub>r" 70)
 notation register_pair ("'(_;_')")
 end
 
 bundle no_register_notation begin
 no_notation register_tensor (infixr "\<otimes>\<^sub>r" 70)
 no_notation register_pair ("'(_;_')")
 end
 
 end
diff --git a/thys/Registers/Laws_Complement.thy b/thys/Registers/Laws_Complement.thy
--- a/thys/Registers/Laws_Complement.thy
+++ b/thys/Registers/Laws_Complement.thy
@@ -1,358 +1,358 @@
 section \<open>Generic laws about complements\<close>
 
 theory Laws_Complement
   imports Laws Axioms_Complement
 begin
 
 notation comp_update (infixl "*\<^sub>u" 55)
 notation tensor_update (infixr "\<otimes>\<^sub>u" 70)
 
 definition \<open>complements F G \<longleftrightarrow> compatible F G \<and> iso_register (F;G)\<close>
 
 lemma complementsI: \<open>compatible F G \<Longrightarrow> iso_register (F;G) \<Longrightarrow> complements F G\<close>
   using complements_def by blast
 
 lemma complements_sym: \<open>complements G F\<close> if \<open>complements F G\<close>
 proof (rule complementsI)
   show [simp]: \<open>compatible G F\<close>
     using compatible_sym complements_def that by blast
   from that have \<open>iso_register (F;G)\<close>
     by (meson complements_def)
   then obtain I where [simp]: \<open>register I\<close> and \<open>(F;G) o I = id\<close> and \<open>I o (F;G) = id\<close>
     using iso_register_def by blast
   have \<open>register (swap o I)\<close>
     using \<open>register I\<close> register_comp register_swap by blast
   moreover have \<open>(G;F) o (swap o I) = id\<close>
     by (simp add: \<open>(F;G) \<circ> I = id\<close> rewriteL_comp_comp)
   moreover have \<open>(swap o I) o (G;F) = id\<close>
-    by (metis (no_types, hide_lams) swap_swap \<open>I \<circ> (F;G) = id\<close> calculation(2) comp_def eq_id_iff)
+    by (metis (no_types, opaque_lifting) swap_swap \<open>I \<circ> (F;G) = id\<close> calculation(2) comp_def eq_id_iff)
   ultimately show \<open>iso_register (G;F)\<close>
     using \<open>compatible G F\<close> iso_register_def pair_is_register by blast
 qed
 
 definition complement :: \<open>('a::domain update \<Rightarrow> 'b::domain update) \<Rightarrow> (('a,'b) complement_domain update \<Rightarrow> 'b update)\<close> where
   \<open>complement F = (SOME G :: ('a, 'b) complement_domain update \<Rightarrow> 'b update. compatible F G \<and> iso_register (F;G))\<close>
 
 lemma register_complement[simp]: \<open>register (complement F)\<close> if \<open>register F\<close>
   using complement_exists[OF that]
   by (metis (no_types, lifting) compatible_def complement_def some_eq_imp)
 
 lemma complement_is_complement:
   assumes \<open>register F\<close>
   shows \<open>complements F (complement F)\<close>
   using complement_exists[OF assms] unfolding complements_def
   by (metis (mono_tags, lifting) complement_def some_eq_imp)
 
 lemma complement_unique:
   assumes \<open>complements F G\<close>
   shows \<open>equivalent_registers G (complement F)\<close>
   apply (rule complement_unique[where F=F])
   using assms unfolding complements_def using compatible_register1 complement_is_complement complements_def by blast+
 
 lemma compatible_complement[simp]: \<open>register F \<Longrightarrow> compatible F (complement F)\<close>
   using complement_is_complement complements_def by blast
 
 lemma complements_register_tensor:
   assumes [simp]: \<open>register F\<close> \<open>register G\<close>
   shows \<open>complements (F \<otimes>\<^sub>r G) (complement F \<otimes>\<^sub>r complement G)\<close>
 proof (rule complementsI)
   have sep4: \<open>separating TYPE('z::domain) {(a \<otimes>\<^sub>u b) \<otimes>\<^sub>u (c \<otimes>\<^sub>u d) |a b c d. True}\<close>
     apply (rule separating_tensor'[where A=\<open>{(a \<otimes>\<^sub>u b) |a b. True}\<close> and B=\<open>{(c \<otimes>\<^sub>u d) |c d. True}\<close>])
       apply (rule separating_tensor'[where A=UNIV and B=UNIV]) apply auto[3]
      apply (rule separating_tensor'[where A=UNIV and B=UNIV]) apply auto[3]
     by auto
   show compat: \<open>compatible (F \<otimes>\<^sub>r G) (complement F \<otimes>\<^sub>r complement G)\<close>
     by (metis assms(1) assms(2) compatible_register_tensor complement_is_complement complements_def)
   let ?reorder = \<open>((Fst o Fst; Snd o Fst); (Fst o Snd; Snd o Snd))\<close>
   have [simp]: \<open>register ?reorder\<close>
     by auto
   have [simp]: \<open>?reorder ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u (c \<otimes>\<^sub>u d)) = ((a \<otimes>\<^sub>u c) \<otimes>\<^sub>u (b \<otimes>\<^sub>u d))\<close> 
     for a::\<open>'t::domain update\<close> and b::\<open>'u::domain update\<close> and c::\<open>'v::domain update\<close> and d::\<open>'w::domain update\<close>
     by (simp add: register_pair_apply Fst_def Snd_def tensor_update_mult)
   have [simp]: \<open>iso_register ?reorder\<close>
     apply (rule iso_registerI[of _ ?reorder]) apply auto[2]
      apply (rule register_eqI[OF sep4]) apply auto[3]
     apply (rule register_eqI[OF sep4]) by auto
   have \<open>(F \<otimes>\<^sub>r G; complement F \<otimes>\<^sub>r complement G) = ((F; complement F) \<otimes>\<^sub>r (G; complement G)) o ?reorder\<close>
     apply (rule register_eqI[OF sep4])
     by (auto intro!: register_preregister register_comp register_tensor_is_register pair_is_register
         simp: compat register_pair_apply tensor_update_mult)
   moreover have \<open>iso_register \<dots>\<close>
     apply (auto intro!: iso_register_comp iso_register_tensor_is_iso_register)
     using assms complement_is_complement complements_def by blast+
   ultimately show \<open>iso_register (F \<otimes>\<^sub>r G;complement F \<otimes>\<^sub>r complement G)\<close>
     by simp
 qed
 
 definition is_unit_register where
   \<open>is_unit_register U \<longleftrightarrow> complements U id\<close>
 
 lemma register_unit_register[simp]: \<open>is_unit_register U \<Longrightarrow> register U\<close>
   by (simp add: compatible_def complements_def is_unit_register_def)
 
 lemma unit_register_compatible[simp]: \<open>compatible U X\<close> if \<open>is_unit_register U\<close> \<open>register X\<close>
   by (metis compatible_comp_right complements_def id_comp is_unit_register_def that(1) that(2))
 
 lemma unit_register_compatible'[simp]: \<open>compatible X U\<close> if \<open>is_unit_register U\<close> \<open>register X\<close>
   using compatible_sym that(1) that(2) unit_register_compatible by blast
 
 lemma compatible_complement_left[simp]: \<open>register X \<Longrightarrow> compatible (complement X) X\<close>
   using compatible_sym complement_is_complement complements_def by blast
 
 lemma compatible_complement_right[simp]: \<open>register X \<Longrightarrow> compatible X (complement X)\<close>
   using complement_is_complement complements_def by blast
 
 lemma unit_register_pair[simp]: \<open>equivalent_registers X (U; X)\<close> if [simp]: \<open>is_unit_register U\<close> \<open>register X\<close>
 proof -
   have \<open>equivalent_registers id (U; id)\<close>
     using complements_def is_unit_register_def iso_register_equivalent_id that(1) by blast
   also have \<open>equivalent_registers \<dots> (U; (X; complement X))\<close>
     apply (rule equivalent_registers_pair_right)
      apply (auto intro!: unit_register_compatible)
     using complement_is_complement complements_def equivalent_registersI id_comp register_id that(2) by blast
   also have \<open>equivalent_registers \<dots> ((U; X); complement X)\<close>
     apply (rule equivalent_registers_assoc)
     by auto
   finally have \<open>complements (U; X) (complement X)\<close>
     by (auto simp: equivalent_registers_def complements_def)
   moreover have \<open>equivalent_registers (X; complement X) id\<close>
     by (metis complement_is_complement complements_def equivalent_registers_def iso_register_def that)
   ultimately show ?thesis
     by (meson complement_unique complement_is_complement complements_sym equivalent_registers_sym equivalent_registers_trans that)
 qed
 
 lemma unit_register_compose_left:
   assumes [simp]: \<open>is_unit_register U\<close>
   assumes [simp]: \<open>register A\<close>
   shows \<open>is_unit_register (A o U)\<close>
 proof -
   have \<open>compatible (A o U) (A; complement A)\<close>
     apply (auto intro!: compatible3')
     by (metis assms(1) assms(2) comp_id compatible_comp_inner complements_def is_unit_register_def)
   then have compat[simp]: \<open>compatible (A o U) id\<close>
     by (metis assms(2) compatible_comp_right complement_is_complement complements_def iso_register_def)
   have \<open>equivalent_registers (A o U; id) (A o U; (A; complement A))\<close>
     apply (auto intro!: equivalent_registers_pair_right)
     using assms(2) complement_is_complement complements_def equivalent_registers_def id_comp register_id by blast
   also have \<open>equivalent_registers \<dots> ((A o U; A o id); complement A)\<close>
     apply auto
-    by (metis (no_types, hide_lams) compat assms(1) assms(2) compatible_comp_left compatible_def compatible_register1 complement_is_complement complements_def equivalent_registers_assoc id_apply register_unit_register)
+    by (metis (no_types, opaque_lifting) compat assms(1) assms(2) compatible_comp_left compatible_def compatible_register1 complement_is_complement complements_def equivalent_registers_assoc id_apply register_unit_register)
   also have \<open>equivalent_registers \<dots> (A o (U; id); complement A)\<close>
-    by (metis (no_types, hide_lams) assms(1) assms(2) calculation complements_def equivalent_registers_sym equivalent_registers_trans is_unit_register_def register_comp_pair)
+    by (metis (no_types, opaque_lifting) assms(1) assms(2) calculation complements_def equivalent_registers_sym equivalent_registers_trans is_unit_register_def register_comp_pair)
   also have \<open>equivalent_registers \<dots> (A o id; complement A)\<close>
     apply (intro equivalent_registers_pair_left equivalent_registers_comp)
       apply (auto simp: assms)
     using assms(1) equivalent_registers_sym register_id unit_register_pair by blast
   also have \<open>equivalent_registers \<dots> id\<close>
     by (metis assms(2) comp_id complement_is_complement complements_def equivalent_registers_def iso_register_inv iso_register_inv_comp2 pair_is_register)
   finally show ?thesis
     using compat complementsI equivalent_registers_sym is_unit_register_def iso_register_equivalent_id by blast
 qed
 
 lemma unit_register_compose_right:
   assumes [simp]: \<open>is_unit_register U\<close>
   assumes [simp]: \<open>iso_register A\<close>
   shows \<open>is_unit_register (U o A)\<close>
 proof (unfold is_unit_register_def, rule complementsI)
   show \<open>compatible (U \<circ> A) id\<close>
     by (simp add: iso_register_is_register)
   have 1: \<open>iso_register ((U;id) \<circ> A \<otimes>\<^sub>r id)\<close>
     by (meson assms(1) assms(2) complements_def is_unit_register_def iso_register_comp iso_register_id iso_register_tensor_is_iso_register)
   have 2: \<open>id \<circ> ((U;id) \<circ> A \<otimes>\<^sub>r id) = (U \<circ> A;id)\<close>
     by (metis assms(1) assms(2) complements_def fun.map_id is_unit_register_def iso_register_id iso_register_is_register pair_o_tensor)
   show \<open>iso_register (U \<circ> A;id)\<close>
     using 1 2 by auto
 qed
 
 lemma unit_register_unique:
   assumes \<open>is_unit_register F\<close>
   assumes \<open>is_unit_register G\<close>
   shows \<open>equivalent_registers F G\<close>
 proof -
   have \<open>complements F id\<close> \<open>complements G id\<close>
     using assms by (metis complements_def equivalent_registers_def id_comp is_unit_register_def)+
   then show ?thesis
     by (meson complement_unique complements_sym equivalent_registers_sym equivalent_registers_trans)
 qed
 
 lemma unit_register_domains_isomorphic:
   fixes F :: \<open>'a::domain update \<Rightarrow> 'c::domain update\<close>
   fixes G :: \<open>'b::domain update \<Rightarrow> 'd::domain update\<close>
   assumes \<open>is_unit_register F\<close>
   assumes \<open>is_unit_register G\<close>
   shows \<open>\<exists>I :: 'a update \<Rightarrow> 'b update. iso_register I\<close>
 proof -
   have \<open>is_unit_register ((\<lambda>d. tensor_update id_update d) o G)\<close>
     by (simp add: assms(2) unit_register_compose_left)
   moreover have \<open>is_unit_register ((\<lambda>c. tensor_update c id_update) o F)\<close>
     using assms(1) register_tensor_left unit_register_compose_left by blast
   ultimately have \<open>equivalent_registers ((\<lambda>d. tensor_update id_update d) o G) ((\<lambda>c. tensor_update c id_update) o F)\<close>
     using unit_register_unique by blast
   then show ?thesis
     unfolding equivalent_registers_def by auto
 qed
 
 
 lemma id_complement_is_unit_register[simp]: \<open>is_unit_register (complement id)\<close>
   by (metis is_unit_register_def complement_is_complement complements_def complements_sym equivalent_registers_def id_comp register_id)
 
 type_synonym unit_register_domain = \<open>(some_domain, some_domain) complement_domain\<close>
 definition unit_register :: \<open>unit_register_domain update \<Rightarrow> 'a::domain update\<close> where \<open>unit_register = (SOME U. is_unit_register U)\<close>
 
 lemma unit_register_is_unit_register[simp]: \<open>is_unit_register (unit_register :: unit_register_domain update \<Rightarrow> 'a::domain update)\<close>
 proof -
   let ?U0 = \<open>complement id :: unit_register_domain update \<Rightarrow> some_domain update\<close>
   let ?U1 = \<open>complement id :: ('a, 'a) complement_domain update \<Rightarrow> 'a update\<close>
   have \<open>is_unit_register ?U0\<close> \<open>is_unit_register ?U1\<close>
     by auto
   then obtain I :: \<open>unit_register_domain update \<Rightarrow> ('a, 'a) complement_domain update\<close> where \<open>iso_register I\<close>
     apply atomize_elim by (rule unit_register_domains_isomorphic)
   with \<open>is_unit_register ?U1\<close> have \<open>is_unit_register (?U1 o I)\<close>
     by (rule unit_register_compose_right)
   then show ?thesis
     by (metis someI_ex unit_register_def)
 qed
 
 lemma unit_register_domain_tensor_unit:
   fixes U :: \<open>'a::domain update \<Rightarrow> _\<close>
   assumes \<open>is_unit_register U\<close>
   shows \<open>\<exists>I :: 'b::domain update \<Rightarrow> ('a*'b) update. iso_register I\<close>
   (* Can we show that I = (\<lambda>x. tensor_update id_update x) ? It would be nice but I do not see how to prove it. *)
 proof -
   have \<open>equivalent_registers (id :: 'b update \<Rightarrow> _) (complement id; id)\<close>
     using id_complement_is_unit_register iso_register_equivalent_id register_id unit_register_pair by blast
   then obtain J :: \<open>'b update \<Rightarrow> ((('b, 'b) complement_domain * 'b) update)\<close> where \<open>iso_register J\<close>
     using equivalent_registers_def iso_register_inv by blast
   moreover obtain K :: \<open>('b, 'b) complement_domain update \<Rightarrow> 'a update\<close> where \<open>iso_register K\<close>
     using assms id_complement_is_unit_register unit_register_domains_isomorphic by blast
   ultimately have \<open>iso_register ((K \<otimes>\<^sub>r id) o J)\<close>
     by auto
   then show ?thesis   
     by auto
 qed
 
 lemma compatible_complement_pair1:
   assumes \<open>compatible F G\<close>
   shows \<open>compatible F (complement (F;G))\<close>
   by (metis assms compatible_comp_left compatible_complement_right pair_is_register register_Fst register_pair_Fst)
 
 lemma compatible_complement_pair2:
   assumes [simp]: \<open>compatible F G\<close>
   shows \<open>compatible G (complement (F;G))\<close>
 proof -
   have \<open>compatible (F;G) (complement (F;G))\<close>
     by simp
   then have \<open>compatible ((F;G) o Snd) (complement (F;G))\<close>
     by auto
   then show ?thesis
     by (auto simp: register_pair_Snd)
 qed
 
 lemma equivalent_complements:
   assumes \<open>complements F G\<close>
   assumes \<open>equivalent_registers G G'\<close>
   shows \<open>complements F G'\<close>
   apply (rule complementsI)
    apply (metis assms(1) assms(2) compatible_comp_right complements_def equivalent_registers_def iso_register_is_register)
   by (metis assms(1) assms(2) complements_def equivalent_registers_def equivalent_registers_pair_right iso_register_comp)
 
 lemma complements_complement_pair:
   assumes [simp]: \<open>compatible F G\<close>
   shows \<open>complements F (G; complement (F;G))\<close>
 proof (rule complementsI)
   have \<open>equivalent_registers (F; (G; complement (F;G))) ((F;G); complement (F;G))\<close>
     apply (rule equivalent_registers_assoc)
     by (auto simp add: compatible_complement_pair1 compatible_complement_pair2)
   also have \<open>equivalent_registers \<dots> id\<close>
     by (meson assms complement_is_complement complements_def equivalent_registers_sym iso_register_equivalent_id pair_is_register)
   finally show \<open>iso_register (F;(G;complement (F;G)))\<close>
     using equivalent_registers_sym iso_register_equivalent_id by blast
   show \<open>compatible F (G;complement (F;G))\<close>
     using assms compatible3' compatible_complement_pair1 compatible_complement_pair2 by blast
 qed
 
 lemma equivalent_registers_complement:
   assumes \<open>equivalent_registers F G\<close>
   shows \<open>equivalent_registers (complement F) (complement G)\<close>
 proof -
   have \<open>complements F (complement F)\<close>
     using assms complement_is_complement equivalent_registers_register_left by blast
   with assms have \<open>complements G (complement F)\<close>
     by (meson complements_sym equivalent_complements)
   then show ?thesis
     by (rule complement_unique)
 qed
 
 
 lemma complements_complement_pair':
   assumes [simp]: \<open>compatible F G\<close>
   shows \<open>complements G (F; complement (F;G))\<close>
 proof -
   have \<open>equivalent_registers (F;G) (G;F)\<close>
     apply (rule equivalent_registersI[where I=swap])
     by auto
   then have \<open>equivalent_registers (complement (F;G)) (complement (G;F))\<close>
     by (rule equivalent_registers_complement)
   then have \<open>equivalent_registers (F; (complement (F;G))) (F; (complement (G;F)))\<close>
     apply (rule equivalent_registers_pair_right[rotated])
     using assms compatible_complement_pair1 by blast
   moreover have \<open>complements G (F; complement (G;F))\<close>
     apply (rule complements_complement_pair)
     using assms compatible_sym by blast
   ultimately show ?thesis
     by (meson equivalent_complements equivalent_registers_sym)
 qed
 
 lemma complements_chain: 
   assumes [simp]: \<open>register F\<close> \<open>register G\<close>
   shows \<open>complements (F o G) (complement F; F o complement G)\<close>
 proof (rule complementsI)
   show \<open>compatible (F o G) (complement F; F o complement G)\<close>
     by auto
   have \<open>equivalent_registers (F \<circ> G;(complement F;F \<circ> complement G)) (F \<circ> G;(F \<circ> complement G;complement F))\<close>
     apply (rule equivalent_registersI[where I=\<open>id \<otimes>\<^sub>r swap\<close>])
     by (auto intro!: iso_register_tensor_is_iso_register simp: pair_o_tensor)
   also have \<open>equivalent_registers \<dots> ((F \<circ> G;F \<circ> complement G);complement F)\<close>
     apply (rule equivalent_registersI[where I=assoc])
     by (auto intro!: iso_register_tensor_is_iso_register simp: pair_o_tensor)
   also have \<open>equivalent_registers \<dots> (F o (G; complement G);complement F)\<close>
     by (metis (no_types, lifting) assms(1) assms(2) calculation compatible_complement_right
         equivalent_registers_sym equivalent_registers_trans register_comp_pair)
   also have \<open>equivalent_registers \<dots> (F o id;complement F)\<close>
     apply (rule equivalent_registers_pair_left, simp)
     apply (rule equivalent_registers_comp, simp)
     by (metis assms(2) complement_is_complement complements_def equivalent_registers_def iso_register_def)
   also have \<open>equivalent_registers \<dots> id\<close>
     by (metis assms(1) comp_id complement_is_complement complements_def equivalent_registers_def iso_register_def)
   finally show \<open>iso_register (F \<circ> G;(complement F;F \<circ> complement G))\<close>
     using equivalent_registers_sym iso_register_equivalent_id by blast
 qed
 
 lemma complements_Fst_Snd[simp]: \<open>complements Fst Snd\<close>
   by (auto intro!: complementsI simp: pair_Fst_Snd)
 
 lemma complements_Snd_Fst[simp]: \<open>complements Snd Fst\<close>
   by (auto intro!: complementsI simp flip: swap_def)
 
 lemma compatible_unit_register[simp]: \<open>register F \<Longrightarrow> compatible F unit_register\<close>
   using compatible_sym unit_register_compatible unit_register_is_unit_register by blast
 
 lemma complements_id_unit_register[simp]: \<open>complements id unit_register\<close>
   using complements_sym is_unit_register_def unit_register_is_unit_register by blast
 
 lemma complements_iso_unit_register: \<open>iso_register I \<Longrightarrow> is_unit_register U \<Longrightarrow> complements I U\<close>
   using complements_sym equivalent_complements is_unit_register_def iso_register_equivalent_id by blast
 
 lemma iso_register_complement_is_unit_register[simp]:
   assumes \<open>iso_register F\<close>
   shows \<open>is_unit_register (complement F)\<close>
   by (meson assms complement_is_complement complements_sym equivalent_complements equivalent_registers_sym is_unit_register_def iso_register_equivalent_id iso_register_is_register)
 
 text \<open>Adding support for \<^term>\<open>is_unit_register F\<close> and \<^term>\<open>complements F G\<close> to the [@{attribute register}] attribute\<close>
 lemmas [register_attribute_rule] = is_unit_register_def[THEN iffD1] complements_def[THEN iffD1]
 lemmas [register_attribute_rule_immediate] = asm_rl[of \<open>is_unit_register _\<close>]
 
 no_notation comp_update (infixl "*\<^sub>u" 55)
 no_notation tensor_update (infixr "\<otimes>\<^sub>u" 70)
 
 end
diff --git a/thys/Registers/Laws_Complement_Quantum.thy b/thys/Registers/Laws_Complement_Quantum.thy
--- a/thys/Registers/Laws_Complement_Quantum.thy
+++ b/thys/Registers/Laws_Complement_Quantum.thy
@@ -1,363 +1,363 @@
 (*
  * This is an autogenerated file. Do not edit.
  * The original is Laws_Complement.thy. It was converted using instantiate_laws.py.
  *)
 
 section \<open>Generic laws about complements, instantiated quantumly\<close>
 
 theory Laws_Complement_Quantum
   imports Laws_Quantum Axioms_Complement_Quantum
 begin
 
 notation cblinfun_compose (infixl "*\<^sub>u" 55)
 notation tensor_op (infixr "\<otimes>\<^sub>u" 70)
 
 definition \<open>complements F G \<longleftrightarrow> compatible F G \<and> iso_register (F;G)\<close>
 
 lemma complementsI: \<open>compatible F G \<Longrightarrow> iso_register (F;G) \<Longrightarrow> complements F G\<close>
   using complements_def by blast
 
 lemma complements_sym: \<open>complements G F\<close> if \<open>complements F G\<close>
 proof (rule complementsI)
   show [simp]: \<open>compatible G F\<close>
     using compatible_sym complements_def that by blast
   from that have \<open>iso_register (F;G)\<close>
     by (meson complements_def)
   then obtain I where [simp]: \<open>register I\<close> and \<open>(F;G) o I = id\<close> and \<open>I o (F;G) = id\<close>
     using iso_register_def by blast
   have \<open>register (swap o I)\<close>
     using \<open>register I\<close> register_comp register_swap by blast
   moreover have \<open>(G;F) o (swap o I) = id\<close>
     by (simp add: \<open>(F;G) \<circ> I = id\<close> rewriteL_comp_comp)
   moreover have \<open>(swap o I) o (G;F) = id\<close>
-    by (metis (no_types, hide_lams) swap_swap \<open>I \<circ> (F;G) = id\<close> calculation(2) comp_def eq_id_iff)
+    by (metis (no_types, opaque_lifting) swap_swap \<open>I \<circ> (F;G) = id\<close> calculation(2) comp_def eq_id_iff)
   ultimately show \<open>iso_register (G;F)\<close>
     using \<open>compatible G F\<close> iso_register_def pair_is_register by blast
 qed
 
 definition complement :: \<open>('a::finite update \<Rightarrow> 'b::finite update) \<Rightarrow> (('a,'b) complement_domain update \<Rightarrow> 'b update)\<close> where
   \<open>complement F = (SOME G :: ('a, 'b) complement_domain update \<Rightarrow> 'b update. compatible F G \<and> iso_register (F;G))\<close>
 
 lemma register_complement[simp]: \<open>register (complement F)\<close> if \<open>register F\<close>
   using complement_exists[OF that]
   by (metis (no_types, lifting) compatible_def complement_def some_eq_imp)
 
 lemma complement_is_complement:
   assumes \<open>register F\<close>
   shows \<open>complements F (complement F)\<close>
   using complement_exists[OF assms] unfolding complements_def
   by (metis (mono_tags, lifting) complement_def some_eq_imp)
 
 lemma complement_unique:
   assumes \<open>complements F G\<close>
   shows \<open>equivalent_registers G (complement F)\<close>
   apply (rule complement_unique[where F=F])
   using assms unfolding complements_def using compatible_register1 complement_is_complement complements_def by blast+
 
 lemma compatible_complement[simp]: \<open>register F \<Longrightarrow> compatible F (complement F)\<close>
   using complement_is_complement complements_def by blast
 
 lemma complements_register_tensor:
   assumes [simp]: \<open>register F\<close> \<open>register G\<close>
   shows \<open>complements (F \<otimes>\<^sub>r G) (complement F \<otimes>\<^sub>r complement G)\<close>
 proof (rule complementsI)
   have sep4: \<open>separating TYPE('z::finite) {(a \<otimes>\<^sub>u b) \<otimes>\<^sub>u (c \<otimes>\<^sub>u d) |a b c d. True}\<close>
     apply (rule separating_tensor'[where A=\<open>{(a \<otimes>\<^sub>u b) |a b. True}\<close> and B=\<open>{(c \<otimes>\<^sub>u d) |c d. True}\<close>])
       apply (rule separating_tensor'[where A=UNIV and B=UNIV]) apply auto[3]
      apply (rule separating_tensor'[where A=UNIV and B=UNIV]) apply auto[3]
     by auto
   show compat: \<open>compatible (F \<otimes>\<^sub>r G) (complement F \<otimes>\<^sub>r complement G)\<close>
     by (metis assms(1) assms(2) compatible_register_tensor complement_is_complement complements_def)
   let ?reorder = \<open>((Fst o Fst; Snd o Fst); (Fst o Snd; Snd o Snd))\<close>
   have [simp]: \<open>register ?reorder\<close>
     by auto
   have [simp]: \<open>?reorder ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u (c \<otimes>\<^sub>u d)) = ((a \<otimes>\<^sub>u c) \<otimes>\<^sub>u (b \<otimes>\<^sub>u d))\<close> 
     for a::\<open>'t::finite update\<close> and b::\<open>'u::finite update\<close> and c::\<open>'v::finite update\<close> and d::\<open>'w::finite update\<close>
     by (simp add: register_pair_apply Fst_def Snd_def comp_tensor_op)
   have [simp]: \<open>iso_register ?reorder\<close>
     apply (rule iso_registerI[of _ ?reorder]) apply auto[2]
      apply (rule register_eqI[OF sep4]) apply auto[3]
     apply (rule register_eqI[OF sep4]) by auto
   have \<open>(F \<otimes>\<^sub>r G; complement F \<otimes>\<^sub>r complement G) = ((F; complement F) \<otimes>\<^sub>r (G; complement G)) o ?reorder\<close>
     apply (rule register_eqI[OF sep4])
     by (auto intro!: register_preregister register_comp register_tensor_is_register pair_is_register
         simp: compat register_pair_apply comp_tensor_op)
   moreover have \<open>iso_register \<dots>\<close>
     apply (auto intro!: iso_register_comp iso_register_tensor_is_iso_register)
     using assms complement_is_complement complements_def by blast+
   ultimately show \<open>iso_register (F \<otimes>\<^sub>r G;complement F \<otimes>\<^sub>r complement G)\<close>
     by simp
 qed
 
 definition is_unit_register where
   \<open>is_unit_register U \<longleftrightarrow> complements U id\<close>
 
 lemma register_unit_register[simp]: \<open>is_unit_register U \<Longrightarrow> register U\<close>
   by (simp add: compatible_def complements_def is_unit_register_def)
 
 lemma unit_register_compatible[simp]: \<open>compatible U X\<close> if \<open>is_unit_register U\<close> \<open>register X\<close>
   by (metis compatible_comp_right complements_def id_comp is_unit_register_def that(1) that(2))
 
 lemma unit_register_compatible'[simp]: \<open>compatible X U\<close> if \<open>is_unit_register U\<close> \<open>register X\<close>
   using compatible_sym that(1) that(2) unit_register_compatible by blast
 
 lemma compatible_complement_left[simp]: \<open>register X \<Longrightarrow> compatible (complement X) X\<close>
   using compatible_sym complement_is_complement complements_def by blast
 
 lemma compatible_complement_right[simp]: \<open>register X \<Longrightarrow> compatible X (complement X)\<close>
   using complement_is_complement complements_def by blast
 
 lemma unit_register_pair[simp]: \<open>equivalent_registers X (U; X)\<close> if [simp]: \<open>is_unit_register U\<close> \<open>register X\<close>
 proof -
   have \<open>equivalent_registers id (U; id)\<close>
     using complements_def is_unit_register_def iso_register_equivalent_id that(1) by blast
   also have \<open>equivalent_registers \<dots> (U; (X; complement X))\<close>
     apply (rule equivalent_registers_pair_right)
      apply (auto intro!: unit_register_compatible)
     using complement_is_complement complements_def equivalent_registersI id_comp register_id that(2) by blast
   also have \<open>equivalent_registers \<dots> ((U; X); complement X)\<close>
     apply (rule equivalent_registers_assoc)
     by auto
   finally have \<open>complements (U; X) (complement X)\<close>
     by (auto simp: equivalent_registers_def complements_def)
   moreover have \<open>equivalent_registers (X; complement X) id\<close>
     by (metis complement_is_complement complements_def equivalent_registers_def iso_register_def that)
   ultimately show ?thesis
     by (meson complement_unique complement_is_complement complements_sym equivalent_registers_sym equivalent_registers_trans that)
 qed
 
 lemma unit_register_compose_left:
   assumes [simp]: \<open>is_unit_register U\<close>
   assumes [simp]: \<open>register A\<close>
   shows \<open>is_unit_register (A o U)\<close>
 proof -
   have \<open>compatible (A o U) (A; complement A)\<close>
     apply (auto intro!: compatible3')
     by (metis assms(1) assms(2) comp_id compatible_comp_inner complements_def is_unit_register_def)
   then have compat[simp]: \<open>compatible (A o U) id\<close>
     by (metis assms(2) compatible_comp_right complement_is_complement complements_def iso_register_def)
   have \<open>equivalent_registers (A o U; id) (A o U; (A; complement A))\<close>
     apply (auto intro!: equivalent_registers_pair_right)
     using assms(2) complement_is_complement complements_def equivalent_registers_def id_comp register_id by blast
   also have \<open>equivalent_registers \<dots> ((A o U; A o id); complement A)\<close>
     apply auto
-    by (metis (no_types, hide_lams) compat assms(1) assms(2) compatible_comp_left compatible_def compatible_register1 complement_is_complement complements_def equivalent_registers_assoc id_apply register_unit_register)
+    by (metis (no_types, opaque_lifting) compat assms(1) assms(2) compatible_comp_left compatible_def compatible_register1 complement_is_complement complements_def equivalent_registers_assoc id_apply register_unit_register)
   also have \<open>equivalent_registers \<dots> (A o (U; id); complement A)\<close>
-    by (metis (no_types, hide_lams) assms(1) assms(2) calculation complements_def equivalent_registers_sym equivalent_registers_trans is_unit_register_def register_comp_pair)
+    by (metis (no_types, opaque_lifting) assms(1) assms(2) calculation complements_def equivalent_registers_sym equivalent_registers_trans is_unit_register_def register_comp_pair)
   also have \<open>equivalent_registers \<dots> (A o id; complement A)\<close>
     apply (intro equivalent_registers_pair_left equivalent_registers_comp)
       apply (auto simp: assms)
     using assms(1) equivalent_registers_sym register_id unit_register_pair by blast
   also have \<open>equivalent_registers \<dots> id\<close>
     by (metis assms(2) comp_id complement_is_complement complements_def equivalent_registers_def iso_register_inv iso_register_inv_comp2 pair_is_register)
   finally show ?thesis
     using compat complementsI equivalent_registers_sym is_unit_register_def iso_register_equivalent_id by blast
 qed
 
 lemma unit_register_compose_right:
   assumes [simp]: \<open>is_unit_register U\<close>
   assumes [simp]: \<open>iso_register A\<close>
   shows \<open>is_unit_register (U o A)\<close>
 proof (unfold is_unit_register_def, rule complementsI)
   show \<open>compatible (U \<circ> A) id\<close>
     by (simp add: iso_register_is_register)
   have 1: \<open>iso_register ((U;id) \<circ> A \<otimes>\<^sub>r id)\<close>
     by (meson assms(1) assms(2) complements_def is_unit_register_def iso_register_comp iso_register_id iso_register_tensor_is_iso_register)
   have 2: \<open>id \<circ> ((U;id) \<circ> A \<otimes>\<^sub>r id) = (U \<circ> A;id)\<close>
     by (metis assms(1) assms(2) complements_def fun.map_id is_unit_register_def iso_register_id iso_register_is_register pair_o_tensor)
   show \<open>iso_register (U \<circ> A;id)\<close>
     using 1 2 by auto
 qed
 
 lemma unit_register_unique:
   assumes \<open>is_unit_register F\<close>
   assumes \<open>is_unit_register G\<close>
   shows \<open>equivalent_registers F G\<close>
 proof -
   have \<open>complements F id\<close> \<open>complements G id\<close>
     using assms by (metis complements_def equivalent_registers_def id_comp is_unit_register_def)+
   then show ?thesis
     by (meson complement_unique complements_sym equivalent_registers_sym equivalent_registers_trans)
 qed
 
 lemma unit_register_domains_isomorphic:
   fixes F :: \<open>'a::finite update \<Rightarrow> 'c::finite update\<close>
   fixes G :: \<open>'b::finite update \<Rightarrow> 'd::finite update\<close>
   assumes \<open>is_unit_register F\<close>
   assumes \<open>is_unit_register G\<close>
   shows \<open>\<exists>I :: 'a update \<Rightarrow> 'b update. iso_register I\<close>
 proof -
   have \<open>is_unit_register ((\<lambda>d. tensor_op id_cblinfun d) o G)\<close>
     by (simp add: assms(2) unit_register_compose_left)
   moreover have \<open>is_unit_register ((\<lambda>c. tensor_op c id_cblinfun) o F)\<close>
     using assms(1) register_tensor_left unit_register_compose_left by blast
   ultimately have \<open>equivalent_registers ((\<lambda>d. tensor_op id_cblinfun d) o G) ((\<lambda>c. tensor_op c id_cblinfun) o F)\<close>
     using unit_register_unique by blast
   then show ?thesis
     unfolding equivalent_registers_def by auto
 qed
 
 
 lemma id_complement_is_unit_register[simp]: \<open>is_unit_register (complement id)\<close>
   by (metis is_unit_register_def complement_is_complement complements_def complements_sym equivalent_registers_def id_comp register_id)
 
 type_synonym unit_register_domain = \<open>(unit, unit) complement_domain\<close>
 definition unit_register :: \<open>unit_register_domain update \<Rightarrow> 'a::finite update\<close> where \<open>unit_register = (SOME U. is_unit_register U)\<close>
 
 lemma unit_register_is_unit_register[simp]: \<open>is_unit_register (unit_register :: unit_register_domain update \<Rightarrow> 'a::finite update)\<close>
 proof -
   let ?U0 = \<open>complement id :: unit_register_domain update \<Rightarrow> unit update\<close>
   let ?U1 = \<open>complement id :: ('a, 'a) complement_domain update \<Rightarrow> 'a update\<close>
   have \<open>is_unit_register ?U0\<close> \<open>is_unit_register ?U1\<close>
     by auto
   then obtain I :: \<open>unit_register_domain update \<Rightarrow> ('a, 'a) complement_domain update\<close> where \<open>iso_register I\<close>
     apply atomize_elim by (rule unit_register_domains_isomorphic)
   with \<open>is_unit_register ?U1\<close> have \<open>is_unit_register (?U1 o I)\<close>
     by (rule unit_register_compose_right)
   then show ?thesis
     by (metis someI_ex unit_register_def)
 qed
 
 lemma unit_register_domain_tensor_unit:
   fixes U :: \<open>'a::finite update \<Rightarrow> _\<close>
   assumes \<open>is_unit_register U\<close>
   shows \<open>\<exists>I :: 'b::finite update \<Rightarrow> ('a*'b) update. iso_register I\<close>
   (* Can we show that I = (\<lambda>x. tensor_op id_cblinfun x) ? It would be nice but I do not see how to prove it. *)
 proof -
   have \<open>equivalent_registers (id :: 'b update \<Rightarrow> _) (complement id; id)\<close>
     using id_complement_is_unit_register iso_register_equivalent_id register_id unit_register_pair by blast
   then obtain J :: \<open>'b update \<Rightarrow> ((('b, 'b) complement_domain * 'b) update)\<close> where \<open>iso_register J\<close>
     using equivalent_registers_def iso_register_inv by blast
   moreover obtain K :: \<open>('b, 'b) complement_domain update \<Rightarrow> 'a update\<close> where \<open>iso_register K\<close>
     using assms id_complement_is_unit_register unit_register_domains_isomorphic by blast
   ultimately have \<open>iso_register ((K \<otimes>\<^sub>r id) o J)\<close>
     by auto
   then show ?thesis   
     by auto
 qed
 
 lemma compatible_complement_pair1:
   assumes \<open>compatible F G\<close>
   shows \<open>compatible F (complement (F;G))\<close>
   by (metis assms compatible_comp_left compatible_complement_right pair_is_register register_Fst register_pair_Fst)
 
 lemma compatible_complement_pair2:
   assumes [simp]: \<open>compatible F G\<close>
   shows \<open>compatible G (complement (F;G))\<close>
 proof -
   have \<open>compatible (F;G) (complement (F;G))\<close>
     by simp
   then have \<open>compatible ((F;G) o Snd) (complement (F;G))\<close>
     by auto
   then show ?thesis
     by (auto simp: register_pair_Snd)
 qed
 
 lemma equivalent_complements:
   assumes \<open>complements F G\<close>
   assumes \<open>equivalent_registers G G'\<close>
   shows \<open>complements F G'\<close>
   apply (rule complementsI)
    apply (metis assms(1) assms(2) compatible_comp_right complements_def equivalent_registers_def iso_register_is_register)
   by (metis assms(1) assms(2) complements_def equivalent_registers_def equivalent_registers_pair_right iso_register_comp)
 
 lemma complements_complement_pair:
   assumes [simp]: \<open>compatible F G\<close>
   shows \<open>complements F (G; complement (F;G))\<close>
 proof (rule complementsI)
   have \<open>equivalent_registers (F; (G; complement (F;G))) ((F;G); complement (F;G))\<close>
     apply (rule equivalent_registers_assoc)
     by (auto simp add: compatible_complement_pair1 compatible_complement_pair2)
   also have \<open>equivalent_registers \<dots> id\<close>
     by (meson assms complement_is_complement complements_def equivalent_registers_sym iso_register_equivalent_id pair_is_register)
   finally show \<open>iso_register (F;(G;complement (F;G)))\<close>
     using equivalent_registers_sym iso_register_equivalent_id by blast
   show \<open>compatible F (G;complement (F;G))\<close>
     using assms compatible3' compatible_complement_pair1 compatible_complement_pair2 by blast
 qed
 
 lemma equivalent_registers_complement:
   assumes \<open>equivalent_registers F G\<close>
   shows \<open>equivalent_registers (complement F) (complement G)\<close>
 proof -
   have \<open>complements F (complement F)\<close>
     using assms complement_is_complement equivalent_registers_register_left by blast
   with assms have \<open>complements G (complement F)\<close>
     by (meson complements_sym equivalent_complements)
   then show ?thesis
     by (rule complement_unique)
 qed
 
 
 lemma complements_complement_pair':
   assumes [simp]: \<open>compatible F G\<close>
   shows \<open>complements G (F; complement (F;G))\<close>
 proof -
   have \<open>equivalent_registers (F;G) (G;F)\<close>
     apply (rule equivalent_registersI[where I=swap])
     by auto
   then have \<open>equivalent_registers (complement (F;G)) (complement (G;F))\<close>
     by (rule equivalent_registers_complement)
   then have \<open>equivalent_registers (F; (complement (F;G))) (F; (complement (G;F)))\<close>
     apply (rule equivalent_registers_pair_right[rotated])
     using assms compatible_complement_pair1 by blast
   moreover have \<open>complements G (F; complement (G;F))\<close>
     apply (rule complements_complement_pair)
     using assms compatible_sym by blast
   ultimately show ?thesis
     by (meson equivalent_complements equivalent_registers_sym)
 qed
 
 lemma complements_chain: 
   assumes [simp]: \<open>register F\<close> \<open>register G\<close>
   shows \<open>complements (F o G) (complement F; F o complement G)\<close>
 proof (rule complementsI)
   show \<open>compatible (F o G) (complement F; F o complement G)\<close>
     by auto
   have \<open>equivalent_registers (F \<circ> G;(complement F;F \<circ> complement G)) (F \<circ> G;(F \<circ> complement G;complement F))\<close>
     apply (rule equivalent_registersI[where I=\<open>id \<otimes>\<^sub>r swap\<close>])
     by (auto intro!: iso_register_tensor_is_iso_register simp: pair_o_tensor)
   also have \<open>equivalent_registers \<dots> ((F \<circ> G;F \<circ> complement G);complement F)\<close>
     apply (rule equivalent_registersI[where I=assoc])
     by (auto intro!: iso_register_tensor_is_iso_register simp: pair_o_tensor)
   also have \<open>equivalent_registers \<dots> (F o (G; complement G);complement F)\<close>
     by (metis (no_types, lifting) assms(1) assms(2) calculation compatible_complement_right
         equivalent_registers_sym equivalent_registers_trans register_comp_pair)
   also have \<open>equivalent_registers \<dots> (F o id;complement F)\<close>
     apply (rule equivalent_registers_pair_left, simp)
     apply (rule equivalent_registers_comp, simp)
     by (metis assms(2) complement_is_complement complements_def equivalent_registers_def iso_register_def)
   also have \<open>equivalent_registers \<dots> id\<close>
     by (metis assms(1) comp_id complement_is_complement complements_def equivalent_registers_def iso_register_def)
   finally show \<open>iso_register (F \<circ> G;(complement F;F \<circ> complement G))\<close>
     using equivalent_registers_sym iso_register_equivalent_id by blast
 qed
 
 lemma complements_Fst_Snd[simp]: \<open>complements Fst Snd\<close>
   by (auto intro!: complementsI simp: pair_Fst_Snd)
 
 lemma complements_Snd_Fst[simp]: \<open>complements Snd Fst\<close>
   by (auto intro!: complementsI simp flip: swap_def)
 
 lemma compatible_unit_register[simp]: \<open>register F \<Longrightarrow> compatible F unit_register\<close>
   using compatible_sym unit_register_compatible unit_register_is_unit_register by blast
 
 lemma complements_id_unit_register[simp]: \<open>complements id unit_register\<close>
   using complements_sym is_unit_register_def unit_register_is_unit_register by blast
 
 lemma complements_iso_unit_register: \<open>iso_register I \<Longrightarrow> is_unit_register U \<Longrightarrow> complements I U\<close>
   using complements_sym equivalent_complements is_unit_register_def iso_register_equivalent_id by blast
 
 lemma iso_register_complement_is_unit_register[simp]:
   assumes \<open>iso_register F\<close>
   shows \<open>is_unit_register (complement F)\<close>
   by (meson assms complement_is_complement complements_sym equivalent_complements equivalent_registers_sym is_unit_register_def iso_register_equivalent_id iso_register_is_register)
 
 text \<open>Adding support for \<^term>\<open>is_unit_register F\<close> and \<^term>\<open>complements F G\<close> to the [@{attribute register}] attribute\<close>
 lemmas [register_attribute_rule] = is_unit_register_def[THEN iffD1] complements_def[THEN iffD1]
 lemmas [register_attribute_rule_immediate] = asm_rl[of \<open>is_unit_register _\<close>]
 
 no_notation cblinfun_compose (infixl "*\<^sub>u" 55)
 no_notation tensor_op (infixr "\<otimes>\<^sub>u" 70)
 
 end
diff --git a/thys/Registers/Laws_Quantum.thy b/thys/Registers/Laws_Quantum.thy
--- a/thys/Registers/Laws_Quantum.thy
+++ b/thys/Registers/Laws_Quantum.thy
@@ -1,819 +1,819 @@
 (*
  * This is an autogenerated file. Do not edit.
  * The original is Laws.thy. It was converted using instantiate_laws.py.
  *)
 
 section \<open>Generic laws about registers, instantiated quantumly\<close>
 
 theory Laws_Quantum
   imports Axioms_Quantum
 begin
 
 text \<open>This notation is only used inside this file\<close>
 notation cblinfun_compose (infixl "*\<^sub>u" 55)
 notation tensor_op (infixr "\<otimes>\<^sub>u" 70)
 notation register_pair ("'(_;_')")
 
 subsection \<open>Elementary facts\<close>
 
 declare complex_vector.linear_id[simp]
 declare cblinfun_compose_id_left[simp]
 declare cblinfun_compose_id_right[simp]
 declare register_preregister[simp]
 declare register_comp[simp]
 declare register_of_id[simp]
 declare register_tensor_left[simp]
 declare register_tensor_right[simp]
 declare preregister_mult_right[simp]
 declare preregister_mult_left[simp]
 declare register_id[simp]
 
 subsection \<open>Preregisters\<close>
 
 lemma preregister_tensor_left[simp]: \<open>clinear (\<lambda>b::'b::finite update. tensor_op a b)\<close>
   for a :: \<open>'a::finite update\<close>
 proof -
   have \<open>clinear ((\<lambda>b1::('a\<times>'b) update. (a \<otimes>\<^sub>u id_cblinfun) *\<^sub>u b1) o (\<lambda>b. tensor_op id_cblinfun b))\<close>
     by (rule clinear_compose; simp)
   then show ?thesis
     by (simp add: o_def comp_tensor_op)
 qed
 
 lemma preregister_tensor_right[simp]: \<open>clinear (\<lambda>a::'a::finite update. tensor_op a b)\<close>  
   for b :: \<open>'b::finite update\<close>
 proof -
   have \<open>clinear ((\<lambda>a1::('a\<times>'b) update. (id_cblinfun \<otimes>\<^sub>u b) *\<^sub>u a1) o (\<lambda>a. tensor_op a id_cblinfun))\<close>
     by (rule clinear_compose, simp_all)
   then show ?thesis
     by (simp add: o_def comp_tensor_op)
 qed
 
 subsection \<open>Registers\<close>
 
 lemma id_update_tensor_register[simp]:
   assumes \<open>register F\<close>
   shows \<open>register (\<lambda>a::'a::finite update. id_cblinfun \<otimes>\<^sub>u F a)\<close>
   using assms apply (rule register_comp[unfolded o_def])
   by simp
 
 lemma register_tensor_id_update[simp]:
   assumes \<open>register F\<close>
   shows \<open>register (\<lambda>a::'a::finite update. F a \<otimes>\<^sub>u id_cblinfun)\<close>
   using assms apply (rule register_comp[unfolded o_def])
   by simp
 
 subsection \<open>Tensor product of registers\<close>
 
 definition register_tensor  (infixr "\<otimes>\<^sub>r" 70) where
   "register_tensor F G = register_pair (\<lambda>a. tensor_op (F a) id_cblinfun) (\<lambda>b. tensor_op id_cblinfun (G b))"
 
 lemma register_tensor_is_register: 
   fixes F :: "'a::finite update \<Rightarrow> 'b::finite update" and G :: "'c::finite update \<Rightarrow> 'd::finite update"
   shows "register F \<Longrightarrow> register G \<Longrightarrow> register (F \<otimes>\<^sub>r G)"
   unfolding register_tensor_def
   apply (rule register_pair_is_register)
   by (simp_all add: comp_tensor_op)
 
 lemma register_tensor_apply[simp]:
   fixes F :: "'a::finite update \<Rightarrow> 'b::finite update" and G :: "'c::finite update \<Rightarrow> 'd::finite update"
   assumes \<open>register F\<close> and \<open>register G\<close>
   shows "(F \<otimes>\<^sub>r G) (a \<otimes>\<^sub>u b) = F a \<otimes>\<^sub>u G b"
   unfolding register_tensor_def
   apply (subst register_pair_apply)
   unfolding register_tensor_def 
   by (simp_all add: assms comp_tensor_op)
 
 definition "separating (_::'b::finite itself) A \<longleftrightarrow> 
   (\<forall>F G :: 'a::finite update \<Rightarrow> 'b update. clinear F \<longrightarrow> clinear G \<longrightarrow> (\<forall>x\<in>A. F x = G x) \<longrightarrow> F = G)"
 
 lemma separating_UNIV[simp]: \<open>separating TYPE(_) UNIV\<close>
   unfolding separating_def by auto
 
 lemma separating_mono: \<open>A \<subseteq> B \<Longrightarrow> separating TYPE('a::finite) A \<Longrightarrow> separating TYPE('a) B\<close>
   unfolding separating_def by (meson in_mono) 
 
 lemma register_eqI: \<open>separating TYPE('b::finite) A \<Longrightarrow> clinear F \<Longrightarrow> clinear G \<Longrightarrow> (\<And>x. x\<in>A \<Longrightarrow> F x = G x) \<Longrightarrow> F = (G::_ \<Rightarrow> 'b update)\<close>
   unfolding separating_def by auto
 
 lemma separating_tensor:
   fixes A :: \<open>'a::finite update set\<close> and B :: \<open>'b::finite update set\<close>
   assumes [simp]: \<open>separating TYPE('c::finite) A\<close>
   assumes [simp]: \<open>separating TYPE('c) B\<close>
   shows \<open>separating TYPE('c) {a \<otimes>\<^sub>u b | a b. a\<in>A \<and> b\<in>B}\<close>
 proof (unfold separating_def, intro allI impI)
   fix F G :: \<open>('a\<times>'b) update \<Rightarrow> 'c update\<close>
   assume [simp]: \<open>clinear F\<close> \<open>clinear G\<close>
   have [simp]: \<open>clinear (\<lambda>x. F (a \<otimes>\<^sub>u x))\<close> for a
     using _ \<open>clinear F\<close> apply (rule clinear_compose[unfolded o_def])
     by simp
   have [simp]: \<open>clinear (\<lambda>x. G (a \<otimes>\<^sub>u x))\<close> for a
     using _ \<open>clinear G\<close> apply (rule clinear_compose[unfolded o_def])
     by simp
   have [simp]: \<open>clinear (\<lambda>x. F (x \<otimes>\<^sub>u b))\<close> for b
     using _ \<open>clinear F\<close> apply (rule clinear_compose[unfolded o_def])
     by simp
   have [simp]: \<open>clinear (\<lambda>x. G (x \<otimes>\<^sub>u b))\<close> for b
     using _ \<open>clinear G\<close> apply (rule clinear_compose[unfolded o_def])
     by simp
 
   assume \<open>\<forall>x\<in>{a \<otimes>\<^sub>u b |a b. a\<in>A \<and> b\<in>B}. F x = G x\<close>
   then have EQ: \<open>F (a \<otimes>\<^sub>u b) = G (a \<otimes>\<^sub>u b)\<close> if \<open>a \<in> A\<close> and \<open>b \<in> B\<close> for a b
     using that by auto
   then have \<open>F (a \<otimes>\<^sub>u b) = G (a \<otimes>\<^sub>u b)\<close> if \<open>a \<in> A\<close> for a b
     apply (rule register_eqI[where A=B, THEN fun_cong, where x=b, rotated -1])
     using that by auto
   then have \<open>F (a \<otimes>\<^sub>u b) = G (a \<otimes>\<^sub>u b)\<close> for a b
     apply (rule register_eqI[where A=A, THEN fun_cong, where x=a, rotated -1])
     by auto
   then show "F = G"
     apply (rule tensor_extensionality[rotated -1])
     by auto
 qed
 
 lemma register_tensor_distrib:
   assumes [simp]: \<open>register F\<close> \<open>register G\<close> \<open>register H\<close> \<open>register L\<close>
   shows \<open>(F \<otimes>\<^sub>r G) o (H \<otimes>\<^sub>r L) = (F o H) \<otimes>\<^sub>r (G o L)\<close>
   apply (rule tensor_extensionality)
   by (auto intro!: register_comp register_preregister register_tensor_is_register)
 
 text \<open>The following is easier to apply using the @{method rule}-method than @{thm [source] separating_tensor}\<close>
 lemma separating_tensor':
   fixes A :: \<open>'a::finite update set\<close> and B :: \<open>'b::finite update set\<close>
   assumes \<open>separating TYPE('c::finite) A\<close>
   assumes \<open>separating TYPE('c) B\<close>
   assumes \<open>C = {a \<otimes>\<^sub>u b | a b. a\<in>A \<and> b\<in>B}\<close>
   shows \<open>separating TYPE('c) C\<close>
   using assms
   by (simp add: separating_tensor)
 
 lemma tensor_extensionality3: 
   fixes F G :: \<open>('a::finite\<times>'b::finite\<times>'c::finite) update \<Rightarrow> 'd::finite update\<close>
   assumes [simp]: \<open>register F\<close> \<open>register G\<close>
   assumes "\<And>f g h. F (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h) = G (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h)"
   shows "F = G"
 proof (rule register_eqI[where A=\<open>{a\<otimes>\<^sub>ub\<otimes>\<^sub>uc| a b c. True}\<close>])
   have \<open>separating TYPE('d) {b \<otimes>\<^sub>u c |b c. True}\<close>
     apply (rule separating_tensor'[where A=UNIV and B=UNIV])
     by auto
   then show \<open>separating TYPE('d) {a \<otimes>\<^sub>u b \<otimes>\<^sub>u c |a b c. True}\<close>
     apply (rule_tac separating_tensor'[where A=UNIV and B=\<open>{b\<otimes>\<^sub>uc| b c. True}\<close>])
     by auto
   show \<open>clinear F\<close> \<open>clinear G\<close> by auto
   show \<open>x \<in> {a \<otimes>\<^sub>u b \<otimes>\<^sub>u c |a b c. True} \<Longrightarrow> F x = G x\<close> for x
     using assms(3) by auto
 qed
 
 lemma tensor_extensionality3': 
   fixes F G :: \<open>(('a::finite\<times>'b::finite)\<times>'c::finite) update \<Rightarrow> 'd::finite update\<close>
   assumes [simp]: \<open>register F\<close> \<open>register G\<close>
   assumes "\<And>f g h. F ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h) = G ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h)"
   shows "F = G"
 proof (rule register_eqI[where A=\<open>{(a\<otimes>\<^sub>ub)\<otimes>\<^sub>uc| a b c. True}\<close>])
   have \<open>separating TYPE('d) {a \<otimes>\<^sub>u b | a b. True}\<close>
     apply (rule separating_tensor'[where A=UNIV and B=UNIV])
     by auto
   then show \<open>separating TYPE('d) {(a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c |a b c. True}\<close>
     apply (rule_tac separating_tensor'[where B=UNIV and A=\<open>{a\<otimes>\<^sub>ub| a b. True}\<close>])
     by auto
   show \<open>clinear F\<close> \<open>clinear G\<close> by auto
   show \<open>x \<in> {(a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c |a b c. True} \<Longrightarrow> F x = G x\<close> for x
     using assms(3) by auto
 qed
 
 lemma register_tensor_id[simp]: \<open>id \<otimes>\<^sub>r id = id\<close>
   apply (rule tensor_extensionality)
   by (auto simp add: register_tensor_is_register)
 
 subsection \<open>Pairs and compatibility\<close>
 
 definition compatible :: \<open>('a::finite update \<Rightarrow> 'c::finite update)
                        \<Rightarrow> ('b::finite update \<Rightarrow> 'c update) \<Rightarrow> bool\<close> where
   \<open>compatible F G \<longleftrightarrow> register F \<and> register G \<and> (\<forall>a b. F a *\<^sub>u G b = G b *\<^sub>u F a)\<close>
 
 lemma compatibleI:
   assumes "register F" and "register G"
   assumes \<open>\<And>a b. (F a) *\<^sub>u (G b) = (G b) *\<^sub>u (F a)\<close>
   shows "compatible F G"
   using assms unfolding compatible_def by simp
 
 lemma swap_registers:
   assumes "compatible R S"
   shows "R a *\<^sub>u S b = S b *\<^sub>u R a"
   using assms unfolding compatible_def by metis
 
 lemma compatible_sym: "compatible x y \<Longrightarrow> compatible y x"
   by (simp add: compatible_def)
 
 lemma pair_is_register[simp]:
   assumes "compatible F G"
   shows "register (F; G)"
   by (metis assms compatible_def register_pair_is_register)
 
 lemma register_pair_apply:
   assumes \<open>compatible F G\<close>
   shows \<open>(F; G) (a \<otimes>\<^sub>u b) = (F a) *\<^sub>u (G b)\<close>
   apply (rule register_pair_apply)
   using assms unfolding compatible_def by metis+
 
 lemma register_pair_apply':
   assumes \<open>compatible F G\<close>
   shows \<open>(F; G) (a \<otimes>\<^sub>u b) = (G b) *\<^sub>u (F a)\<close>
   apply (subst register_pair_apply)
   using assms by (auto simp: compatible_def intro: register_preregister)
 
 
 
 lemma compatible_comp_left[simp]: "compatible F G \<Longrightarrow> register H \<Longrightarrow> compatible (F \<circ> H) G"
   by (simp add: compatible_def)
 
 lemma compatible_comp_right[simp]: "compatible F G \<Longrightarrow> register H \<Longrightarrow> compatible F (G \<circ> H)"
   by (simp add: compatible_def)
 
 lemma compatible_comp_inner[simp]: 
   "compatible F G \<Longrightarrow> register H \<Longrightarrow> compatible (H \<circ> F) (H \<circ> G)"
   by (smt (verit, best) comp_apply compatible_def register_comp register_mult)
 
 lemma compatible_register1: \<open>compatible F G \<Longrightarrow> register F\<close>
   by (simp add: compatible_def)
 lemma compatible_register2: \<open>compatible F G \<Longrightarrow> register G\<close>
   by (simp add: compatible_def)
 
 lemma pair_o_tensor:
   assumes "compatible A B" and [simp]: \<open>register C\<close> and [simp]: \<open>register D\<close>
   shows "(A; B) o (C \<otimes>\<^sub>r D) = (A o C; B o D)"
   apply (rule tensor_extensionality)
   using assms by (simp_all add: register_tensor_is_register register_pair_apply clinear_compose)
 
 lemma compatible_tensor_id_update_left[simp]:
   fixes F :: "'a::finite update \<Rightarrow> 'c::finite update" and G :: "'b::finite update \<Rightarrow> 'c::finite update"
   assumes "compatible F G"
   shows "compatible (\<lambda>a. id_cblinfun \<otimes>\<^sub>u F a) (\<lambda>a. id_cblinfun \<otimes>\<^sub>u G a)"
   using assms apply (rule compatible_comp_inner[unfolded o_def])
   by simp
 
 lemma compatible_tensor_id_update_right[simp]:
   fixes F :: "'a::finite update \<Rightarrow> 'c::finite update" and G :: "'b::finite update \<Rightarrow> 'c::finite update"
   assumes "compatible F G"
   shows "compatible (\<lambda>a. F a \<otimes>\<^sub>u id_cblinfun) (\<lambda>a. G a \<otimes>\<^sub>u id_cblinfun)"
   using assms apply (rule compatible_comp_inner[unfolded o_def])
   by simp
 
 lemma compatible_tensor_id_update_rl[simp]:
   assumes "register F" and "register G"
   shows "compatible (\<lambda>a. F a \<otimes>\<^sub>u id_cblinfun) (\<lambda>a. id_cblinfun \<otimes>\<^sub>u G a)"
   apply (rule compatibleI)
   using assms by (auto simp: comp_tensor_op)
 
 lemma compatible_tensor_id_update_lr[simp]:
   assumes "register F" and "register G"
   shows "compatible (\<lambda>a. id_cblinfun \<otimes>\<^sub>u F a) (\<lambda>a. G a \<otimes>\<^sub>u id_cblinfun)"
   apply (rule compatibleI)
   using assms by (auto simp: comp_tensor_op)
 
 lemma register_comp_pair:
   assumes [simp]: \<open>register F\<close> and [simp]: \<open>compatible G H\<close>
   shows "(F o G; F o H) = F o (G; H)"
 proof (rule tensor_extensionality)
   show \<open>clinear (F \<circ> G;F \<circ> H)\<close> and \<open>clinear (F \<circ> (G;H))\<close>
     by simp_all
 
   have [simp]: \<open>compatible (F o G) (F o H)\<close>
     apply (rule compatible_comp_inner, simp)
     by simp
   then have [simp]: \<open>register (F \<circ> G)\<close> \<open>register (F \<circ> H)\<close>
     unfolding compatible_def by auto
   from assms have [simp]: \<open>register G\<close> \<open>register H\<close>
     unfolding compatible_def by auto
   fix a b
   show \<open>(F \<circ> G;F \<circ> H) (a \<otimes>\<^sub>u b) = (F \<circ> (G;H)) (a \<otimes>\<^sub>u b)\<close>
     by (auto simp: register_pair_apply register_mult comp_tensor_op)
 qed
 
 lemma swap_registers_left:
   assumes "compatible R S"
   shows "R a *\<^sub>u S b *\<^sub>u c = S b *\<^sub>u R a *\<^sub>u c"
   using assms unfolding compatible_def by metis
 
 lemma swap_registers_right:
   assumes "compatible R S"
   shows "c *\<^sub>u R a *\<^sub>u S b = c *\<^sub>u S b *\<^sub>u R a"
   by (metis assms cblinfun_compose_assoc compatible_def)
 
 lemmas compatible_ac_rules = swap_registers cblinfun_compose_assoc[symmetric] swap_registers_right
 
 subsection \<open>Fst and Snd\<close>
 
 definition Fst where \<open>Fst a = a \<otimes>\<^sub>u id_cblinfun\<close>
 definition Snd where \<open>Snd a = id_cblinfun \<otimes>\<^sub>u a\<close>
 
 lemma register_Fst[simp]: \<open>register Fst\<close>
   unfolding Fst_def by (rule register_tensor_left)
 
 lemma register_Snd[simp]: \<open>register Snd\<close>
   unfolding Snd_def by (rule register_tensor_right)
 
 lemma compatible_Fst_Snd[simp]: \<open>compatible Fst Snd\<close>
   apply (rule compatibleI, simp, simp)
   by (simp add: Fst_def Snd_def comp_tensor_op)
 
 lemmas compatible_Snd_Fst[simp] = compatible_Fst_Snd[THEN compatible_sym]
 
 definition \<open>swap = (Snd; Fst)\<close>
 
 lemma swap_apply[simp]: "swap (a \<otimes>\<^sub>u b) = (b \<otimes>\<^sub>u a)"
   unfolding swap_def
   by (simp add: Axioms_Quantum.register_pair_apply Fst_def Snd_def comp_tensor_op) 
 
 lemma swap_o_Fst: "swap o Fst = Snd"
   by (auto simp add: Fst_def Snd_def)
 lemma swap_o_Snd: "swap o Snd = Fst"
   by (auto simp add: Fst_def Snd_def)
 
 lemma register_swap[simp]: \<open>register swap\<close>
   by (simp add: swap_def)
 
 lemma pair_Fst_Snd: \<open>(Fst; Snd) = id\<close>
   apply (rule tensor_extensionality)
   by (simp_all add: register_pair_apply Fst_def Snd_def comp_tensor_op)
 
 lemma swap_o_swap[simp]: \<open>swap o swap = id\<close>
   by (metis swap_def compatible_Snd_Fst pair_Fst_Snd register_comp_pair register_swap swap_o_Fst swap_o_Snd)
 
 lemma swap_swap[simp]: \<open>swap (swap x) = x\<close>
   by (simp add: pointfree_idE)
 
 lemma inv_swap[simp]: \<open>inv swap = swap\<close>
   by (meson inv_unique_comp swap_o_swap)
 
 lemma register_pair_Fst:
   assumes \<open>compatible F G\<close>
   shows \<open>(F;G) o Fst = F\<close>
   using assms by (auto intro!: ext simp: Fst_def register_pair_apply compatible_register2)
 
 lemma register_pair_Snd:
   assumes \<open>compatible F G\<close>
   shows \<open>(F;G) o Snd = G\<close>
   using assms by (auto intro!: ext simp: Snd_def register_pair_apply compatible_register1)
 
 lemma register_Fst_register_Snd[simp]:
   assumes \<open>register F\<close>
   shows \<open>(F o Fst; F o Snd) = F\<close>
   apply (rule tensor_extensionality)
   using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult comp_tensor_op)
 
 lemma register_Snd_register_Fst[simp]: 
   assumes \<open>register F\<close>
   shows \<open>(F o Snd; F o Fst) = F o swap\<close>
   apply (rule tensor_extensionality)
   using assms by (auto simp: register_pair_apply Fst_def Snd_def register_mult comp_tensor_op)
 
 
 lemma compatible3[simp]:
   assumes [simp]: "compatible F G" and "compatible G H" and "compatible F H"
   shows "compatible (F; G) H"
 proof (rule compatibleI)
   have [simp]: \<open>register F\<close> \<open>register G\<close> \<open>register H\<close>
     using assms compatible_def by auto
   then have [simp]: \<open>clinear F\<close> \<open>clinear G\<close> \<open>clinear H\<close>
     using register_preregister by blast+
   have [simp]: \<open>clinear (\<lambda>a. (F;G) a *\<^sub>u z)\<close> for z
     apply (rule clinear_compose[unfolded o_def, of \<open>(F;G)\<close>])
     by simp_all
   have [simp]: \<open>clinear (\<lambda>a. z *\<^sub>u (F;G) a)\<close> for z
     apply (rule clinear_compose[unfolded o_def, of \<open>(F;G)\<close>])
     by simp_all
   have "(F; G) (f \<otimes>\<^sub>u g) *\<^sub>u H h = H h *\<^sub>u (F; G) (f \<otimes>\<^sub>u g)" for f g h
   proof -
     have FH: "F f *\<^sub>u H h = H h *\<^sub>u F f"
       using assms compatible_def by metis
     have GH: "G g *\<^sub>u H h = H h *\<^sub>u G g"
       using assms compatible_def by metis
     have \<open>(F; G) (f \<otimes>\<^sub>u g) *\<^sub>u (H h) = F f *\<^sub>u G g *\<^sub>u H h\<close>
       using \<open>compatible F G\<close> by (subst register_pair_apply, auto)
     also have \<open>\<dots> = H h *\<^sub>u F f *\<^sub>u G g\<close>
       using FH GH by (metis cblinfun_compose_assoc)
     also have \<open>\<dots> = H h *\<^sub>u (F; G) (f \<otimes>\<^sub>u g)\<close>
       using \<open>compatible F G\<close> by (subst register_pair_apply, auto simp: cblinfun_compose_assoc)
     finally show ?thesis
       by -
   qed
   then show "(F; G) fg *\<^sub>u (H h) = (H h) *\<^sub>u (F; G) fg" for fg h
     apply (rule_tac tensor_extensionality[THEN fun_cong])
     by auto
   show "register H" and  "register (F; G)"
     by simp_all
 qed
 
 lemma compatible3'[simp]:
   assumes "compatible F G" and "compatible G H" and "compatible F H"
   shows "compatible F (G; H)"
   apply (rule compatible_sym)
   apply (rule compatible3)
   using assms by (auto simp: compatible_sym)
 
 lemma pair_o_swap[simp]:
   assumes [simp]: "compatible A B"
   shows "(A; B) o swap = (B; A)"
 proof (rule tensor_extensionality)
   have [simp]: "clinear A" "clinear B"
-     apply (metis (no_types, hide_lams) assms compatible_register1 register_preregister)
+     apply (metis (no_types, opaque_lifting) assms compatible_register1 register_preregister)
     by (metis (full_types) assms compatible_register2 register_preregister)
   then show \<open>clinear ((A; B) \<circ> swap)\<close>
     by simp
   show \<open>clinear (B; A)\<close>
     by (metis (no_types, lifting) assms compatible_sym register_preregister pair_is_register)
   show \<open>((A; B) \<circ> swap) (a \<otimes>\<^sub>u b) = (B; A) (a \<otimes>\<^sub>u b)\<close> for a b
     (* Without the "only:", we would not need the "apply subst",
        but that proof fails when instantiated in Classical.thy *)
     apply (simp only: o_def swap_apply)
     apply (subst register_pair_apply, simp)
     apply (subst register_pair_apply, simp add: compatible_sym)
     by (metis (no_types, lifting) assms compatible_def)
 qed
 
 
 subsection \<open>Compatibility of register tensor products\<close>
 
 lemma compatible_register_tensor:
   fixes F :: \<open>'a::finite update \<Rightarrow> 'e::finite update\<close> and G :: \<open>'b::finite update \<Rightarrow> 'f::finite update\<close>
     and F' :: \<open>'c::finite update \<Rightarrow> 'e update\<close> and G' :: \<open>'d::finite update \<Rightarrow> 'f update\<close>
   assumes [simp]: \<open>compatible F F'\<close>
   assumes [simp]: \<open>compatible G G'\<close>
   shows \<open>compatible (F \<otimes>\<^sub>r G) (F' \<otimes>\<^sub>r G')\<close>
 proof -
   note [intro!] = 
     clinear_compose[OF _ preregister_mult_right, unfolded o_def]
     clinear_compose[OF _ preregister_mult_left, unfolded o_def]
     clinear_compose
     register_tensor_is_register
   have [simp]: \<open>register F\<close> \<open>register G\<close> \<open>register F'\<close> \<open>register G'\<close>
     using assms compatible_def by blast+
   have [simp]: \<open>register (F \<otimes>\<^sub>r G)\<close> \<open>register (F' \<otimes>\<^sub>r G')\<close>
     by (auto simp add: register_tensor_def)
   have [simp]: \<open>register (F;F')\<close> \<open>register (G;G')\<close>
     by auto
   define reorder :: \<open>(('a\<times>'b) \<times> ('c\<times>'d)) update \<Rightarrow> (('a\<times>'c) \<times> ('b\<times>'d)) update\<close>
     where \<open>reorder = ((Fst o Fst; Snd o Fst); (Fst o Snd; Snd o Snd))\<close>
   have [simp]: \<open>clinear reorder\<close>
     by (auto simp: reorder_def)
   have [simp]: \<open>reorder ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u (c \<otimes>\<^sub>u d)) = ((a \<otimes>\<^sub>u c) \<otimes>\<^sub>u (b \<otimes>\<^sub>u d))\<close> for a b c d
     apply (simp add: reorder_def register_pair_apply)
     by (simp add: Fst_def Snd_def comp_tensor_op)
   define \<Phi> where \<open>\<Phi> c d = ((F;F') \<otimes>\<^sub>r (G;G')) o reorder o (\<lambda>\<sigma>. \<sigma> \<otimes>\<^sub>u (c \<otimes>\<^sub>u d))\<close> for c d
   have [simp]: \<open>clinear (\<Phi> c d)\<close> for c d
     unfolding \<Phi>_def 
     by (auto intro: register_preregister)
   have \<open>\<Phi> c d (a \<otimes>\<^sub>u b) = (F \<otimes>\<^sub>r G) (a \<otimes>\<^sub>u b) *\<^sub>u (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d)\<close> for a b c d
     unfolding \<Phi>_def by (auto simp: register_pair_apply comp_tensor_op)
   then have \<Phi>1: \<open>\<Phi> c d \<sigma> = (F \<otimes>\<^sub>r G) \<sigma> *\<^sub>u (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d)\<close> for c d \<sigma>
     apply (rule_tac fun_cong[of _ _ \<sigma>])
     apply (rule tensor_extensionality)
     by auto
   have \<open>\<Phi> c d (a \<otimes>\<^sub>u b) = (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d) *\<^sub>u (F \<otimes>\<^sub>r G) (a \<otimes>\<^sub>u b)\<close> for a b c d
     unfolding \<Phi>_def apply (auto simp: register_pair_apply)
     by (metis assms(1) assms(2) compatible_def comp_tensor_op)
   then have \<Phi>2: \<open>\<Phi> c d \<sigma> = (F' \<otimes>\<^sub>r G') (c \<otimes>\<^sub>u d) *\<^sub>u (F \<otimes>\<^sub>r G) \<sigma>\<close> for c d \<sigma>
     apply (rule_tac fun_cong[of _ _ \<sigma>])
     apply (rule tensor_extensionality)
     by auto
   from \<Phi>1 \<Phi>2 have \<open>(F \<otimes>\<^sub>r G) \<sigma> *\<^sub>u (F' \<otimes>\<^sub>r G') \<tau> = (F' \<otimes>\<^sub>r G') \<tau> *\<^sub>u (F \<otimes>\<^sub>r G) \<sigma>\<close> for \<tau> \<sigma>
     apply (rule_tac fun_cong[of _ _ \<tau>])
     apply (rule tensor_extensionality)
     by auto
   then show ?thesis
     apply (rule compatibleI[rotated -1])
     by auto
 qed
 
 subsection \<open>Associativity of the tensor product\<close>
 
 definition assoc :: \<open>(('a::finite\<times>'b::finite)\<times>'c::finite) update \<Rightarrow> ('a\<times>('b\<times>'c)) update\<close> where 
   \<open>assoc = ((Fst; Snd o Fst); Snd o Snd)\<close>
 
 lemma assoc_is_hom[simp]: \<open>clinear assoc\<close>
   by (auto simp: assoc_def)
 
 lemma assoc_apply[simp]: \<open>assoc ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c) = (a \<otimes>\<^sub>u (b \<otimes>\<^sub>u c))\<close>
   by (auto simp: assoc_def register_pair_apply Fst_def Snd_def comp_tensor_op)
 
 definition assoc' :: \<open>('a\<times>('b\<times>'c)) update \<Rightarrow> (('a::finite\<times>'b::finite)\<times>'c::finite) update\<close> where 
   \<open>assoc' = (Fst o Fst; (Fst o Snd; Snd))\<close>
 
 lemma assoc'_is_hom[simp]: \<open>clinear assoc'\<close>
   by (auto simp: assoc'_def)
 
 lemma assoc'_apply[simp]: \<open>assoc' (a \<otimes>\<^sub>u (b \<otimes>\<^sub>u c)) =  ((a \<otimes>\<^sub>u b) \<otimes>\<^sub>u c)\<close>
   by (auto simp: assoc'_def register_pair_apply Fst_def Snd_def comp_tensor_op)
 
 lemma register_assoc[simp]: \<open>register assoc\<close>
   unfolding assoc_def
   by force
 
 lemma register_assoc'[simp]: \<open>register assoc'\<close>
   unfolding assoc'_def 
   by force
 
 lemma pair_o_assoc[simp]:
   assumes [simp]: \<open>compatible F G\<close> \<open>compatible G H\<close> \<open>compatible F H\<close>
   shows \<open>(F; (G; H)) \<circ> assoc = ((F; G); H)\<close>
 proof (rule tensor_extensionality3')
   show \<open>register ((F; (G; H)) \<circ> assoc)\<close>
     by simp
   show \<open>register ((F; G); H)\<close>
     by simp
   show \<open>((F; (G; H)) \<circ> assoc) ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h) = ((F; G); H) ((f \<otimes>\<^sub>u g) \<otimes>\<^sub>u h)\<close> for f g h
     by (simp add: register_pair_apply assoc_apply cblinfun_compose_assoc)
 qed
 
 lemma pair_o_assoc'[simp]:
   assumes [simp]: \<open>compatible F G\<close> \<open>compatible G H\<close> \<open>compatible F H\<close>
   shows \<open>((F; G); H) \<circ> assoc' = (F; (G; H))\<close>
 proof (rule tensor_extensionality3)
   show \<open>register (((F; G); H) \<circ> assoc')\<close>
     by simp
   show \<open>register (F; (G; H))\<close>
     by simp
   show \<open>(((F; G); H) \<circ> assoc') (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h) = (F; (G; H)) (f \<otimes>\<^sub>u g \<otimes>\<^sub>u h)\<close> for f g h
     by (simp add: register_pair_apply assoc'_apply cblinfun_compose_assoc)
 qed
 
 lemma assoc'_o_assoc[simp]: \<open>assoc' o assoc = id\<close>
   apply (rule tensor_extensionality3')
   by auto
 
 lemma assoc'_assoc[simp]: \<open>assoc' (assoc x) = x\<close>
   by (simp add: pointfree_idE)
 
 lemma assoc_o_assoc'[simp]: \<open>assoc o assoc' = id\<close>
   apply (rule tensor_extensionality3)
   by auto
 
 lemma assoc_assoc'[simp]: \<open>assoc (assoc' x) = x\<close>
   by (simp add: pointfree_idE)
 
 lemma inv_assoc[simp]: \<open>inv assoc = assoc'\<close>
   using assoc'_o_assoc assoc_o_assoc' inv_unique_comp by blast
 
 lemma inv_assoc'[simp]: \<open>inv assoc' = assoc\<close>
   by (simp add: inv_equality)
 
 lemma [simp]: \<open>bij assoc\<close>
   using assoc'_o_assoc assoc_o_assoc' o_bij by blast
 
 lemma [simp]: \<open>bij assoc'\<close>
   using assoc'_o_assoc assoc_o_assoc' o_bij by blast
 
 subsection \<open>Iso-registers\<close>
 
 definition \<open>iso_register F \<longleftrightarrow> register F \<and> (\<exists>G. register G \<and> F o G = id \<and> G o F = id)\<close>
   for F :: \<open>_::finite update \<Rightarrow> _::finite update\<close>
 
 lemma iso_registerI:
   assumes \<open>register F\<close> \<open>register G\<close> \<open>F o G = id\<close> \<open>G o F = id\<close>
   shows \<open>iso_register F\<close>
   using assms(1) assms(2) assms(3) assms(4) iso_register_def by blast
 
 lemma iso_register_inv: \<open>iso_register F \<Longrightarrow> iso_register (inv F)\<close>
   by (metis inv_unique_comp iso_register_def)
 
 lemma iso_register_inv_comp1: \<open>iso_register F \<Longrightarrow> inv F o F = id\<close>
   using inv_unique_comp iso_register_def by blast
 
 lemma iso_register_inv_comp2: \<open>iso_register F \<Longrightarrow> F o inv F = id\<close>
   using inv_unique_comp iso_register_def by blast
 
 
 lemma iso_register_id[simp]: \<open>iso_register id\<close>
   by (simp add: iso_register_def)
 
 lemma iso_register_is_register: \<open>iso_register F \<Longrightarrow> register F\<close>
   using iso_register_def by blast
 
 lemma iso_register_comp[simp]:
   assumes [simp]: \<open>iso_register F\<close> \<open>iso_register G\<close>
   shows \<open>iso_register (F o G)\<close>
 proof -
   from assms obtain F' G' where [simp]: \<open>register F'\<close> \<open>register G'\<close> \<open>F o F' = id\<close> \<open>F' o F = id\<close>
     \<open>G o G' = id\<close> \<open>G' o G = id\<close>
     by (meson iso_register_def)
   show ?thesis
     apply (rule iso_registerI[where G=\<open>G' o F'\<close>])
        apply (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
      apply (metis \<open>F \<circ> F' = id\<close> \<open>G \<circ> G' = id\<close> fcomp_assoc fcomp_comp id_fcomp)
     by (metis (no_types, lifting) \<open>F \<circ> F' = id\<close> \<open>F' \<circ> F = id\<close> \<open>G' \<circ> G = id\<close> fun.map_comp inj_iff inv_unique_comp o_inv_o_cancel)
 qed
 
 
 lemma iso_register_tensor_is_iso_register[simp]:
   assumes [simp]: \<open>iso_register F\<close> \<open>iso_register G\<close>
   shows \<open>iso_register (F \<otimes>\<^sub>r G)\<close>
 proof -
   from assms obtain F' G' where [simp]: \<open>register F'\<close> \<open>register G'\<close> \<open>F o F' = id\<close> \<open>F' o F = id\<close>
     \<open>G o G' = id\<close> \<open>G' o G = id\<close>
     by (meson iso_register_def)
   show ?thesis
     apply (rule iso_registerI[where G=\<open>F' \<otimes>\<^sub>r G'\<close>])
     by (auto simp: register_tensor_is_register iso_register_is_register register_tensor_distrib)
 qed
 
 lemma iso_register_bij: \<open>iso_register F \<Longrightarrow> bij F\<close>
   using iso_register_def o_bij by auto
 
 lemma inv_register_tensor[simp]: 
   assumes [simp]: \<open>iso_register F\<close> \<open>iso_register G\<close>
   shows \<open>inv (F \<otimes>\<^sub>r G) = inv F \<otimes>\<^sub>r inv G\<close>
   apply (auto intro!: inj_imp_inv_eq bij_is_inj iso_register_bij 
               simp: register_tensor_distrib[unfolded o_def, THEN fun_cong] iso_register_is_register
                     iso_register_inv bij_is_surj iso_register_bij surj_f_inv_f)
   by (metis eq_id_iff register_tensor_id)
 
 lemma iso_register_swap[simp]: \<open>iso_register swap\<close>
   apply (rule iso_registerI[of _ swap])
   by auto
 
 lemma iso_register_assoc[simp]: \<open>iso_register assoc\<close>
   apply (rule iso_registerI[of _ assoc'])
   by auto
 
 lemma iso_register_assoc'[simp]: \<open>iso_register assoc'\<close>
   apply (rule iso_registerI[of _ assoc])
   by auto
 
 definition \<open>equivalent_registers F G \<longleftrightarrow> (register F \<and> (\<exists>I. iso_register I \<and> F o I = G))\<close>
   for F G :: \<open>_::finite update \<Rightarrow> _::finite update\<close>
 
 lemma iso_register_equivalent_id[simp]: \<open>equivalent_registers id F \<longleftrightarrow> iso_register F\<close>
   by (simp add: equivalent_registers_def)
 
 lemma equivalent_registersI:
   assumes \<open>register F\<close>
   assumes \<open>iso_register I\<close>
   assumes \<open>F o I = G\<close>
   shows \<open>equivalent_registers F G\<close>
   using assms unfolding equivalent_registers_def by blast
 
 lemma equivalent_registers_register_left: \<open>equivalent_registers F G \<Longrightarrow> register F\<close>
   using equivalent_registers_def by auto
 
 lemma equivalent_registers_register_right: \<open>register G\<close> if \<open>equivalent_registers F G\<close>
   by (metis equivalent_registers_def iso_register_def register_comp that)
 
 lemma equivalent_registers_sym:
   assumes \<open>equivalent_registers F G\<close>
   shows \<open>equivalent_registers G F\<close>
   by (smt (verit) assms comp_id equivalent_registers_def equivalent_registers_register_right fun.map_comp iso_register_def)
 
 lemma equivalent_registers_trans[trans]: 
   assumes \<open>equivalent_registers F G\<close> and \<open>equivalent_registers G H\<close>
   shows \<open>equivalent_registers F H\<close>
 proof -
   from assms have [simp]: \<open>register F\<close> \<open>register G\<close>
     by (auto simp: equivalent_registers_def)
   from assms(1) obtain I where [simp]: \<open>iso_register I\<close> and \<open>F o I = G\<close>
     using equivalent_registers_def by blast
   from assms(2) obtain J where [simp]: \<open>iso_register J\<close> and \<open>G o J = H\<close>
     using equivalent_registers_def by blast
   have \<open>register F\<close>
     by (auto simp: equivalent_registers_def)
   moreover have \<open>iso_register (I o J)\<close>
     using \<open>iso_register I\<close> \<open>iso_register J\<close> iso_register_comp by blast
   moreover have \<open>F o (I o J) = H\<close>
     by (simp add: \<open>F \<circ> I = G\<close> \<open>G \<circ> J = H\<close> o_assoc)
   ultimately show ?thesis
     by (rule equivalent_registersI)
 qed
 
 lemma equivalent_registers_assoc[simp]:
   assumes [simp]: \<open>compatible F G\<close> \<open>compatible F H\<close> \<open>compatible G H\<close>
   shows \<open>equivalent_registers (F;(G;H)) ((F;G);H)\<close>
   apply (rule equivalent_registersI[where I=assoc])
   by auto
 
 lemma equivalent_registers_pair_right:
   assumes [simp]: \<open>compatible F G\<close>
   assumes eq: \<open>equivalent_registers G H\<close>
   shows \<open>equivalent_registers (F;G) (F;H)\<close>
 proof -
   from eq obtain I where [simp]: \<open>iso_register I\<close> and \<open>G o I = H\<close>
     by (metis equivalent_registers_def)
   then have *: \<open>(F;G) \<circ> (id \<otimes>\<^sub>r I) = (F;H)\<close>
     by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register 
         simp:  register_pair_apply iso_register_is_register)
   show ?thesis
     apply (rule equivalent_registersI[where I=\<open>id \<otimes>\<^sub>r I\<close>])
     using * by (auto intro!: iso_register_tensor_is_iso_register)
 qed
 
 lemma equivalent_registers_pair_left:
   assumes [simp]: \<open>compatible F G\<close>
   assumes eq: \<open>equivalent_registers F H\<close>
   shows \<open>equivalent_registers (F;G) (H;G)\<close>
 proof -
   from eq obtain I where [simp]: \<open>iso_register I\<close> and \<open>F o I = H\<close>
     by (metis equivalent_registers_def)
   then have *: \<open>(F;G) \<circ> (I \<otimes>\<^sub>r id) = (H;G)\<close>
     by (auto intro!: tensor_extensionality register_comp register_preregister register_tensor_is_register 
         simp:  register_pair_apply iso_register_is_register)
   show ?thesis
     apply (rule equivalent_registersI[where I=\<open>I \<otimes>\<^sub>r id\<close>])
     using * by (auto intro!: iso_register_tensor_is_iso_register)
 qed
 
 lemma equivalent_registers_comp:
   assumes \<open>register H\<close>
   assumes \<open>equivalent_registers F G\<close>
   shows \<open>equivalent_registers (H o F) (H o G)\<close>
   by (metis (no_types, lifting) assms(1) assms(2) comp_assoc equivalent_registers_def register_comp)
 
 subsection \<open>Compatibility simplification\<close>
 
 text \<open>The simproc \<open>compatibility_warn\<close> produces helpful warnings for subgoals of the form
    \<^term>\<open>compatible x y\<close> that are probably unsolvable due to missing declarations of 
    variable compatibility facts. Same for subgoals of the form \<^term>\<open>register x\<close>.\<close>
 simproc_setup "compatibility_warn" ("compatible x y" | "register x") = \<open>
 let val thy_string = Markup.markup (Theory.get_markup \<^theory>) (Context.theory_name \<^theory>)
 in
 fn m => fn ctxt => fn ct => let
   val (x,y) = case Thm.term_of ct of
                  Const(\<^const_name>\<open>compatible\<close>,_ ) $ x $ y => (x, SOME y)
                | Const(\<^const_name>\<open>register\<close>,_ ) $ x => (x, NONE)
   val str : string lazy = Lazy.lazy (fn () => Syntax.string_of_term ctxt (Thm.term_of ct))
   fun w msg = warning (msg ^ "\n(Disable these warnings with: using [[simproc del: "^thy_string^".compatibility_warn]])")
   val _ = case (x,y) of
         (Free(n,T), SOME (Free(n',T'))) => 
             if String.isPrefix ":" n orelse String.isPrefix ":" n' then 
                       w ("Simplification subgoal " ^ Lazy.force str ^ " contains a bound variable.\n" ^
                       "Try to add some assumptions that makes this goal solvable by the simplifier")
             else if n=n' then (if T=T' then () 
                           else w ("In simplification subgoal " ^ Lazy.force str ^ 
                                ", variables have same name and different types.\n" ^
                                "Probably something is wrong."))
                     else w ("Simplification subgoal " ^ Lazy.force str ^ 
                             " occurred but cannot be solved.\n" ^
                             "Please add assumption/fact  [simp]: \<open>" ^ Lazy.force str ^ 
                             "\<close>  somewhere.")
       | (Free(n,T), NONE) => 
             if String.isPrefix ":" n then 
                       w ("Simplification subgoal '" ^ Lazy.force str ^ "' contains a bound variable.\n" ^
                       "Try to add some assumptions that makes this goal solvable by the simplifier")
             else w ("Simplification subgoal " ^ Lazy.force str ^ " occurred but cannot be solved.\n" ^
                     "Please add assumption/fact  [simp]: \<open>" ^ Lazy.force str ^ "\<close>  somewhere.")
       | _ => ()
   in NONE end
 end\<close>
 
 
 named_theorems register_attribute_rule_immediate
 named_theorems register_attribute_rule
 
 lemmas [register_attribute_rule] = conjunct1 conjunct2 iso_register_is_register iso_register_is_register[OF iso_register_inv]
 lemmas [register_attribute_rule_immediate] = compatible_sym compatible_register1 compatible_register2
   asm_rl[of \<open>compatible _ _\<close>] asm_rl[of \<open>iso_register _\<close>] asm_rl[of \<open>register _\<close>] iso_register_inv
 
 text \<open>The following declares an attribute \<open>[register]\<close>. When the attribute is applied to a fact
   of the form \<^term>\<open>register F\<close>, \<^term>\<open>iso_register F\<close>, \<^term>\<open>compatible F G\<close> or a conjunction of these,
   then those facts are added to the simplifier together with some derived theorems
   (e.g., \<^term>\<open>compatible F G\<close> also adds \<^term>\<open>register F\<close>).
 
   In theory \<open>Laws_Complement\<close>, support for \<^term>\<open>is_unit_register F\<close> and \<^term>\<open>complements F G\<close> is
   added to this attribute.\<close>
 
 setup \<open>
 let
 fun add thm results = 
   Net.insert_term (K true) (Thm.concl_of thm, thm) results
   handle Net.INSERT => results
 fun try_rule f thm rule state = case SOME (rule OF [thm]) handle THM _ => NONE  of
   NONE => state | SOME th => f th state
 fun collect (rules,rules_immediate) thm results =
   results |> fold (try_rule add thm) rules_immediate |> fold (try_rule (collect (rules,rules_immediate)) thm) rules
 fun declare thm context = let
   val ctxt = Context.proof_of context
   val rules = Named_Theorems.get ctxt @{named_theorems register_attribute_rule}
   val rules_immediate = Named_Theorems.get ctxt @{named_theorems register_attribute_rule_immediate}
   val thms = collect (rules,rules_immediate) thm Net.empty |> Net.entries
   (* val _ = \<^print> thms *)
   in Simplifier.map_ss (fn ctxt => ctxt addsimps thms) context end
 in
 Attrib.setup \<^binding>\<open>register\<close>
  (Scan.succeed (Thm.declaration_attribute declare))
   "Add register-related rules to the simplifier"
 end
 \<close>
 
 subsection \<open>Notation\<close>
 
 no_notation cblinfun_compose (infixl "*\<^sub>u" 55)
 no_notation tensor_op (infixr "\<otimes>\<^sub>u" 70)
 
 bundle register_notation begin
 notation register_tensor (infixr "\<otimes>\<^sub>r" 70)
 notation register_pair ("'(_;_')")
 end
 
 bundle no_register_notation begin
 no_notation register_tensor (infixr "\<otimes>\<^sub>r" 70)
 no_notation register_pair ("'(_;_')")
 end
 
 end
diff --git a/thys/Registers/Misc.thy b/thys/Registers/Misc.thy
--- a/thys/Registers/Misc.thy
+++ b/thys/Registers/Misc.thy
@@ -1,160 +1,161 @@
 section \<open>Miscellaneous facts\<close>
 
 text \<open>This theory proves various facts that are not directly related to this developments 
 but do not occur in the imported theories.\<close>
 
 theory Misc
   imports
     Complex_Bounded_Operators.Cblinfun_Code
     "HOL-Library.Z2"
     Jordan_Normal_Form.Matrix
 begin
 
 \<comment> \<open>Remove notation that collides with the notation we use\<close>
 no_notation Order.top ("\<top>\<index>")
 no_notation m_inv ("inv\<index> _" [81] 80)
 unbundle no_vec_syntax
 unbundle no_inner_syntax
 
 \<comment> \<open>Import notation from Bounded Operator and Jordan Normal Form libraries\<close>
 unbundle cblinfun_notation
 unbundle jnf_notation
 
 
 abbreviation "butterket i j \<equiv> butterfly (ket i) (ket j)"
 abbreviation "selfbutterket i \<equiv> butterfly (ket i) (ket i)"
 
 text \<open>The following declares the ML antiquotation \<^verbatim>\<open>fact\<close>. In ML code,
   \<^verbatim>\<open>@{fact f}\<close> for a theorem/fact name f is replaced by an ML string
   containing a printable(!) representation of fact. (I.e.,
   if you print that string using writeln, the user can ctrl-click on it.)
 
   This is useful when constructing diagnostic messages in ML code, e.g., 
   \<^verbatim>\<open>"Use the theorem " ^ @{fact thmname} ^ "here."\<close>\<close>
 
 setup \<open>ML_Antiquotation.inline_embedded \<^binding>\<open>fact\<close>
 ((Args.context -- Scan.lift Args.name_position) >> (fn (ctxt,namepos) => let
   val facts = Proof_Context.facts_of ctxt
   val fullname = Facts.check (Context.Proof ctxt) facts namepos
   val (markup, shortname) = Proof_Context.markup_extern_fact ctxt fullname
   val string = Markup.markups markup shortname
   in ML_Syntax.print_string string end
 ))
 \<close>
 
 
 instantiation bit :: enum begin
 definition "enum_bit = [0::bit,1]"
 definition "enum_all_bit P \<longleftrightarrow> P (0::bit) \<and> P 1"
 definition "enum_ex_bit P \<longleftrightarrow> P (0::bit) \<or> P 1"
 instance
   apply intro_classes
      apply (auto simp: enum_bit_def enum_all_bit_def enum_ex_bit_def)
-  by (metis bit_not_one_imp)+
+   apply (metis bit_not_one_iff)
+  by (metis bit_not_zero_iff)
 end
 
 lemma card_bit[simp]: "CARD(bit) = 2"
   using card_2_iff' by force
 
 instantiation bit :: card_UNIV begin
 definition "finite_UNIV = Phantom(bit) True"
 definition "card_UNIV = Phantom(bit) 2"
 instance
   apply intro_classes
   by (simp_all add: finite_UNIV_bit_def card_UNIV_bit_def)
 end
 
 lemma mat_of_rows_list_carrier[simp]:
   "mat_of_rows_list n vs \<in> carrier_mat (length vs) n"
   "dim_row (mat_of_rows_list n vs) = length vs"
   "dim_col (mat_of_rows_list n vs) = n"
   unfolding mat_of_rows_list_def by auto
 
 lemma apply_id_cblinfun[simp]: \<open>(*\<^sub>V) id_cblinfun = id\<close>
   by auto
 
 text \<open>Overriding \\<^theory>\<open>Complex_Bounded_Operators.Complex_Bounded_Linear_Function\<close>.\<^term>\<open>sandwich\<close>.
       The latter is the same function but defined as a \<^typ>\<open>(_,_) cblinfun\<close> which is less convenient for us.\<close>
 definition sandwich where \<open>sandwich a b = a o\<^sub>C\<^sub>L b o\<^sub>C\<^sub>L a*\<close>
 
 lemma clinear_sandwich[simp]: \<open>clinear (sandwich a)\<close>
   apply (rule clinearI)
    apply (simp add: bounded_cbilinear.add_left bounded_cbilinear_cblinfun_compose bounded_cbilinear.add_right sandwich_def)
   by (simp add: sandwich_def)
 
 lemma sandwich_id[simp]: \<open>sandwich id_cblinfun = id\<close>
   by (auto simp: sandwich_def)
 
 lemma mat_of_cblinfun_sandwich:
   fixes a :: "(_::onb_enum, _::onb_enum) cblinfun"
   shows \<open>mat_of_cblinfun (sandwich a b) = (let a' = mat_of_cblinfun a in a' * mat_of_cblinfun b * mat_adjoint a')\<close>
   by (simp add: mat_of_cblinfun_compose sandwich_def Let_def mat_of_cblinfun_adj)
 
 lemma prod_cases3' [cases type]:
   obtains (fields) a b c where "y = ((a, b), c)"
   by (cases y, case_tac a) blast
 
 lemma lift_cblinfun_comp:
   assumes \<open>a o\<^sub>C\<^sub>L b = c\<close>
   shows \<open>a o\<^sub>C\<^sub>L b = c\<close>
     and \<open>a o\<^sub>C\<^sub>L (b o\<^sub>C\<^sub>L d) = c o\<^sub>C\<^sub>L d\<close>
     and \<open>a *\<^sub>S (b *\<^sub>S S) = c *\<^sub>S S\<close>
     and \<open>a *\<^sub>V (b *\<^sub>V x) = c *\<^sub>V x\<close>
      apply (fact assms)
     apply (simp add: assms cblinfun_assoc_left(1))
   using assms cblinfun_assoc_left(2) apply force
   using assms by force
 
 text \<open>We define the following abbreviations:
 \<^item> \<open>mutually f (x\<^sub>1,x\<^sub>2,\<dots>,x\<^sub>n)\<close> expands to the conjuction of all \<^term>\<open>f x\<^sub>i x\<^sub>j\<close> with \<^term>\<open>i\<noteq>j\<close>.
 \<^item> \<open>each f (x\<^sub>1,x\<^sub>2,\<dots>,x\<^sub>n)\<close> expands to the conjuction of all \<^term>\<open>f x\<^sub>i\<close>.\<close>
 
 syntax "_mutually" :: "'a \<Rightarrow> args \<Rightarrow> 'b" ("mutually _ '(_')")
 syntax "_mutually2" :: "'a \<Rightarrow> 'b \<Rightarrow> args \<Rightarrow> args \<Rightarrow> 'c"
 
 translations "mutually f (x)" => "CONST True"
 translations "mutually f (_args x y)" => "f x y \<and> f y x"
 translations "mutually f (_args x (_args x' xs))" => "_mutually2 f x (_args x' xs) (_args x' xs)"
 translations "_mutually2 f x y zs" => "f x y \<and> f y x \<and> _mutually f zs"
 translations "_mutually2 f x (_args y ys) zs" => "f x y \<and> f y x \<and> _mutually2 f x ys zs"
 
 syntax "_each" :: "'a \<Rightarrow> args \<Rightarrow> 'b" ("each _ '(_')")
 translations "each f (x)" => "f x"
 translations "_each f (_args x xs)" => "f x \<and> _each f xs"
 
 
 lemma enum_inj:
   assumes "i < CARD('a)" and "j < CARD('a)"
   shows "(Enum.enum ! i :: 'a::enum) = Enum.enum ! j \<longleftrightarrow> i = j"
   using inj_on_nth[OF enum_distinct, where I=\<open>{..<CARD('a)}\<close>]
   using assms by (auto dest: inj_onD simp flip: card_UNIV_length_enum)
 
 
 lemma [simp]: "dim_col (mat_adjoint m) = dim_row m"
   unfolding mat_adjoint_def by simp
 lemma [simp]: "dim_row (mat_adjoint m) = dim_col m"
   unfolding mat_adjoint_def by simp
 
 lemma invI: 
   assumes \<open>inj f\<close>
   assumes \<open>x = f y\<close>
   shows \<open>inv f x = y\<close>
   by (simp add: assms(1) assms(2))
 
 instantiation prod :: (default,default) default begin
 definition \<open>default_prod = (default, default)\<close>
 instance..
 end
 
 instance bit :: default..
 
 lemma surj_from_comp:
   assumes \<open>surj (g o f)\<close>
   assumes \<open>inj g\<close>
   shows \<open>surj f\<close>
   by (metis assms(1) assms(2) f_inv_into_f fun.set_map inj_image_mem_iff iso_tuple_UNIV_I surj_iff_all)
 
 lemma double_exists: \<open>(\<exists>x y. Q x y) \<longleftrightarrow> (\<exists>z. Q (fst z) (snd z))\<close>
   by simp
 
 end
diff --git a/thys/Registers/Pure_States.thy b/thys/Registers/Pure_States.thy
--- a/thys/Registers/Pure_States.thy
+++ b/thys/Registers/Pure_States.thy
@@ -1,575 +1,577 @@
 theory Pure_States
   imports Quantum_Extra2 "HOL-Eisbach.Eisbach"
 begin
 
 definition \<open>pure_state_target_vector F \<eta>\<^sub>F = (if ket default \<in> range (cblinfun_apply (F (butterfly \<eta>\<^sub>F \<eta>\<^sub>F)))
    then ket default
    else (SOME \<eta>'. norm \<eta>' = 1 \<and> \<eta>' \<in> range (cblinfun_apply (F (butterfly \<eta>\<^sub>F \<eta>\<^sub>F)))))\<close>
 
 lemma pure_state_target_vector_eqI:
   assumes \<open>F (butterfly \<eta>\<^sub>F \<eta>\<^sub>F) = G (butterfly \<eta>\<^sub>G \<eta>\<^sub>G)\<close>
   shows \<open>pure_state_target_vector F \<eta>\<^sub>F = pure_state_target_vector G \<eta>\<^sub>G\<close>
   by (simp add: assms pure_state_target_vector_def)
 
 lemma pure_state_target_vector_ket_default: \<open>pure_state_target_vector F \<eta>\<^sub>F = ket default\<close> if \<open>ket default \<in> range (cblinfun_apply (F (butterfly \<eta>\<^sub>F \<eta>\<^sub>F)))\<close>
   by (simp add: pure_state_target_vector_def that)
 
 lemma
   assumes [simp]: \<open>\<eta>\<^sub>F \<noteq> 0\<close> \<open>register F\<close>
   shows pure_state_target_vector_in_range: \<open>pure_state_target_vector F \<eta>\<^sub>F \<in> range ((*\<^sub>V) (F (selfbutter \<eta>\<^sub>F)))\<close> (is ?range)
     and pure_state_target_vector_norm: \<open>norm (pure_state_target_vector F \<eta>\<^sub>F) = 1\<close> (is ?norm)
 proof -
   from assms have \<open>selfbutter \<eta>\<^sub>F \<noteq> 0\<close>
     by (metis butterfly_0_right complex_vector.scale_zero_right inj_selfbutter_upto_phase)
   then have \<open>F (selfbutter \<eta>\<^sub>F) \<noteq> 0\<close>
     using register_inj[OF \<open>register F\<close>, THEN injD, where y=0]
     by (auto simp: complex_vector.linear_0)
   then obtain \<psi>' where \<psi>': \<open>F (selfbutter \<eta>\<^sub>F) *\<^sub>V \<psi>' \<noteq> 0\<close>
     by (meson cblinfun_eq_0_on_UNIV_span complex_vector.span_UNIV)
   have ex: \<open>\<exists>\<psi>. norm \<psi> = 1 \<and> \<psi> \<in> range ((*\<^sub>V) (F (selfbutter \<eta>\<^sub>F)))\<close>
     apply (rule exI[of _ \<open>(F (selfbutter \<eta>\<^sub>F) *\<^sub>V \<psi>') /\<^sub>C norm (F (selfbutter \<eta>\<^sub>F) *\<^sub>V \<psi>')\<close>])
     using \<psi>' apply (auto simp add: norm_inverse)
     by (metis cblinfun.scaleC_right rangeI)
   then show ?range
     by (metis (mono_tags, lifting) pure_state_target_vector_def verit_sko_ex')
   show ?norm
     apply (simp add: pure_state_target_vector_def)
     using ex by (metis (mono_tags, lifting) verit_sko_ex')
 qed
 
 
 lemma pure_state_target_vector_correct: 
   assumes [simp]: \<open>\<eta> \<noteq> 0\<close> \<open>register F\<close>
   shows \<open>F (selfbutter \<eta>) *\<^sub>V pure_state_target_vector F \<eta> \<noteq> 0\<close>
 proof -
   obtain \<psi> where \<psi>: \<open>F (selfbutter \<eta>) \<psi> = pure_state_target_vector F \<eta>\<close>
     apply atomize_elim
     using pure_state_target_vector_in_range[OF assms]
     by (smt (verit, best) image_iff top_ccsubspace.rep_eq top_set_def)
 
   define n where \<open>n = cinner \<eta> \<eta>\<close>
   then have \<open>n \<noteq> 0\<close>
     by auto
 
   have pure_state_target_vector_neq0: \<open>pure_state_target_vector F \<eta> \<noteq> 0\<close>
     using pure_state_target_vector_norm[OF assms]
     by auto
 
   have \<open>F (selfbutter \<eta>) *\<^sub>V pure_state_target_vector F \<eta> = F (selfbutter \<eta>) *\<^sub>V F (selfbutter \<eta>) *\<^sub>V \<psi>\<close>
     by (simp add: \<psi>)
   also have \<open>\<dots> = n *\<^sub>C F (selfbutter \<eta>) *\<^sub>V \<psi>\<close>
     by (simp flip: cblinfun_apply_cblinfun_compose add: register_mult register_scaleC n_def)
   also have \<open>\<dots> = n *\<^sub>C pure_state_target_vector F \<eta>\<close>
     by (simp add: \<psi>)
   also have \<open>\<dots> \<noteq> 0\<close>
     using pure_state_target_vector_neq0 \<open>n \<noteq> 0\<close>
     by auto
   finally show ?thesis
     by -
 qed
 
 definition \<open>pure_state' F \<psi> \<eta>\<^sub>F = F (butterfly \<psi> \<eta>\<^sub>F) *\<^sub>V pure_state_target_vector F \<eta>\<^sub>F\<close>
 
 abbreviation \<open>pure_state F \<psi> \<equiv> pure_state' F \<psi> (ket default)\<close>
 
 nonterminal pure_tensor
 syntax "_pure_tensor" :: \<open>'a \<Rightarrow> 'b \<Rightarrow> pure_tensor \<Rightarrow> pure_tensor\<close> ("_ _ \<otimes>\<^sub>p _" [1000, 0, 0] 1000)
 syntax "_pure_tensor2" :: \<open>'a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> pure_tensor\<close> ("_ _ \<otimes>\<^sub>p _ _" [1000, 0, 1000, 0] 1000)
 syntax "_pure_tensor1" :: \<open>'a \<Rightarrow> 'b \<Rightarrow> pure_tensor\<close>
 syntax "_pure_tensor_start" :: \<open>pure_tensor \<Rightarrow> 'a\<close> ("'(_')")
 
 translations
   "_pure_tensor2 F \<psi> G \<phi>" \<rightharpoonup> "CONST pure_state (F; G) (\<psi> \<otimes>\<^sub>s \<phi>)"
   "_pure_tensor F \<psi> (CONST pure_state G \<phi>)" \<rightharpoonup> "CONST pure_state (F; G) (\<psi> \<otimes>\<^sub>s \<phi>)"
   "_pure_tensor_start x" \<rightharpoonup> "x"
 
   "_pure_tensor_start (_pure_tensor2 F \<psi> G \<phi>)" \<leftharpoondown> "CONST pure_state (F; G) (\<psi> \<otimes>\<^sub>s \<phi>)"
   "_pure_tensor F \<psi> (_pure_tensor2 G \<phi> H \<eta>)" \<leftharpoondown> "_pure_tensor2 F \<psi> (G;H) (\<phi> \<otimes>\<^sub>s \<eta>)"
 
 term \<open>(F \<psi> \<otimes>\<^sub>p G \<phi> \<otimes>\<^sub>p H z)\<close>
 term \<open>pure_state (F; G) (a \<otimes>\<^sub>s b)\<close>
 
 lemma register_pair_butterfly_tensor: \<open>(F; G) (butterfly (a \<otimes>\<^sub>s b) (c \<otimes>\<^sub>s d)) = F (butterfly a c) o\<^sub>C\<^sub>L G (butterfly b d)\<close>
   if [simp]: \<open>compatible F G\<close>
   by (auto simp: default_prod_def simp flip: tensor_ell2_ket tensor_butterfly register_pair_apply)
 
 lemma pure_state_eqI:
   assumes \<open>F (selfbutter \<eta>\<^sub>F) = G (selfbutter \<eta>\<^sub>G)\<close>
   assumes \<open>F (butterfly \<psi> \<eta>\<^sub>F) = G (butterfly \<phi> \<eta>\<^sub>G)\<close>
   shows \<open>pure_state' F \<psi> \<eta>\<^sub>F = pure_state' G \<phi> \<eta>\<^sub>G\<close>
 proof -
   from assms(1) have \<open>pure_state_target_vector F \<eta>\<^sub>F = pure_state_target_vector G \<eta>\<^sub>G\<close>
     by (rule pure_state_target_vector_eqI)
   with assms(2)
   show ?thesis
     unfolding pure_state'_def
     by simp
 qed
 
 
 definition \<open>regular_register F \<longleftrightarrow> register F \<and> (\<exists>a. (F; complement F) (selfbutterket default \<otimes>\<^sub>o a) = selfbutterket default)\<close>
 
 lemma regular_registerI:
   assumes [simp]: \<open>register F\<close>
   assumes [simp]: \<open>complements F G\<close>
   assumes eq: \<open>(F; G) (selfbutterket default \<otimes>\<^sub>o a) = selfbutterket default\<close>
   shows \<open>regular_register F\<close>
 proof -
   have [simp]: \<open>compatible F G\<close>
     using assms by (simp add: complements_def)
   from \<open>complements F G\<close>
   obtain I where cFI: \<open>complement F o I = G\<close> and \<open>iso_register I\<close>
     apply atomize_elim
     by (meson Laws_Complement_Quantum.complement_unique equivalent_registers_def equivalent_registers_sym)
   have \<open>(F; complement F) (selfbutterket default \<otimes>\<^sub>o I a) = (F; G) (selfbutterket default \<otimes>\<^sub>o a)\<close>
     using cFI by (auto simp: register_pair_apply)
   also have \<open>\<dots> = selfbutterket default\<close>
     by (rule eq)
   finally show ?thesis
     unfolding regular_register_def by auto
 qed
 
 lemma regular_register_pair:
   assumes [simp]: \<open>compatible F G\<close>
   assumes \<open>regular_register F\<close> and \<open>regular_register G\<close>
   shows \<open>regular_register (F;G)\<close>
 proof -
   have [simp]: \<open>bij (F;complement F)\<close> \<open>bij (G;complement G)\<close>
     using assms(1) compatible_def complement_is_complement complements_def iso_register_bij by blast+
   have [simp]: \<open>bij ((F;G);complement (F;G))\<close>
     using assms(1) complement_is_complement complements_def iso_register_bij pair_is_register by blast
   have [simp]: \<open>register F\<close> \<open>register G\<close>
     using assms(1) unfolding compatible_def by auto
 
   obtain aF where [simp]: \<open>inv (F;complement F) (selfbutterket default) = selfbutterket default \<otimes>\<^sub>o aF\<close>
     by (metis assms(2) compatible_complement_right invI pair_is_register register_inj regular_register_def)
   obtain aG where [simp]: \<open>inv (G;complement G) (selfbutterket default) = selfbutterket default \<otimes>\<^sub>o aG\<close>
     by (metis assms(3) complement_is_complement complements_def inj_iff inv_f_f iso_register_inv_comp1 regular_register_def)
   define t1 where \<open>t1 = inv ((F;G); complement (F;G)) (selfbutterket default)\<close>
   define t2 where \<open>t2 = inv (F; (G; complement (F;G))) (selfbutterket default)\<close>
   define t3 where \<open>t3 = inv (G; (F; complement (F;G))) (selfbutterket default)\<close>
 
 
   have \<open>complements F (G; complement (F;G))\<close>
     apply (rule complements_complement_pair)
     by simp
   then have \<open>equivalent_registers (complement F) (G; complement (F;G))\<close>
     using Laws_Complement_Quantum.complement_unique equivalent_registers_sym by blast
   then obtain I where [simp]: \<open>iso_register I\<close> and I: \<open>(G; complement (F;G)) = complement F o I\<close>
     by (metis equivalent_registers_def)
   then have [simp]: \<open>register I\<close>
     by (meson iso_register_is_register)
   have [simp]: \<open>bij (id \<otimes>\<^sub>r I)\<close>
     by (rule iso_register_bij, simp)
   have [simp]: \<open>inv (id \<otimes>\<^sub>r I) = id \<otimes>\<^sub>r inv I\<close>
     by auto
 
   have \<open>t2 = (inv (id \<otimes>\<^sub>r I) o inv (F;complement F)) (selfbutterket default)\<close>
     unfolding t2_def I
     apply (subst o_inv_distrib[symmetric]) 
     by (auto simp: pair_o_tensor)
   also have \<open>\<dots> = (selfbutterket default \<otimes>\<^sub>o inv I aF)\<close>
     apply auto
     by (metis \<open>iso_register I\<close> id_def iso_register_def iso_register_inv register_id register_tensor_apply)
   finally have t2': \<open>t2 = selfbutterket default \<otimes>\<^sub>o inv I aF\<close>
     by simp
 
   have *: \<open>complements G (F; complement (F;G))\<close>
     apply (rule complements_complement_pair')
     by simp
   then have [simp]: \<open>compatible G (F; complement (F;G))\<close>
     using complements_def by blast
   from * have \<open>equivalent_registers (complement G) (F; complement (F;G))\<close>
     using complement_unique equivalent_registers_sym by blast
   then obtain J where [simp]: \<open>iso_register J\<close> and I: \<open>(F; complement (F;G)) = complement G o J\<close>
     by (metis equivalent_registers_def)
   then have [simp]: \<open>register J\<close>
     by (meson iso_register_is_register)
   have [simp]: \<open>bij (id \<otimes>\<^sub>r J)\<close>
     by (rule iso_register_bij, simp)
   have [simp]: \<open>inv (id \<otimes>\<^sub>r J) = id \<otimes>\<^sub>r inv J\<close>
     by auto
 
   have \<open>t3 = (inv (id \<otimes>\<^sub>r J) o inv (G;complement G)) (selfbutterket default)\<close>
     unfolding t3_def I
     apply (subst o_inv_distrib[symmetric]) 
     by (auto simp: pair_o_tensor)
   also have \<open>\<dots> = (selfbutterket default \<otimes>\<^sub>o inv J aG)\<close>
     apply auto
     by (metis \<open>iso_register J\<close> id_def iso_register_def iso_register_inv register_id register_tensor_apply)
   finally have t3': \<open>t3 = selfbutterket default \<otimes>\<^sub>o inv J aG\<close>
     by simp
 
   have *: \<open>((F;G); complement (F;G)) o assoc' = (F; (G; complement (F;G)))\<close>
     apply (rule tensor_extensionality3)
     by (auto simp: register_pair_apply  compatible_complement_pair1 compatible_complement_pair2)
   have t2_t1: \<open>t2 = assoc t1\<close>
     unfolding t1_def t2_def *[symmetric] apply (subst o_inv_distrib)
     by auto
 
   have *: \<open>((F;G); complement (F;G)) o (swap \<otimes>\<^sub>r id) o assoc' = (G; (F; complement (F;G)))\<close>
     apply (rule tensor_extensionality3)
       apply (auto intro!: register_comp register_tensor_is_register pair_is_register complements_complement_pair
         simp: register_pair_apply compatible_complement_pair1)
     by (metis assms(1) cblinfun_assoc_left(1) swap_registers_left)
   have t3_t1: \<open>t3 = assoc ((swap \<otimes>\<^sub>r id) t1)\<close>
     unfolding t1_def t3_def *[symmetric] apply (subst o_inv_distrib)
     by (auto intro!: bij_comp simp: iso_register_bij o_inv_distrib)
 
   from \<open>t2 = assoc t1\<close> \<open>t3 = assoc ((swap \<otimes>\<^sub>r id) t1)\<close>
   have *: \<open>selfbutterket default \<otimes>\<^sub>o inv J aG =  assoc ((swap \<otimes>\<^sub>r id) (assoc' (selfbutterket default \<otimes>\<^sub>o inv I aF)))\<close>
     by (simp add: t2' t3')
 
   have \<open>selfbutterket default \<otimes>\<^sub>o swap (inv J aG) = (id \<otimes>\<^sub>r swap) (selfbutterket default \<otimes>\<^sub>o inv J aG)\<close>
     by auto
   also have \<open>\<dots> = ((id \<otimes>\<^sub>r swap) o assoc o (swap \<otimes>\<^sub>r id) o assoc') (selfbutterket default \<otimes>\<^sub>o inv I aF)\<close>
     by (simp add: *)
   also have \<open>\<dots> = (assoc o swap) (selfbutterket default \<otimes>\<^sub>o inv I aF)\<close>
     apply (rule fun_cong[where g=\<open>assoc o swap\<close>])
     apply (intro tensor_extensionality3 register_comp register_tensor_is_register)
     by auto
   also have \<open>\<dots> = assoc (inv I aF \<otimes>\<^sub>o selfbutterket default)\<close>
     by auto
   finally have *: \<open>selfbutterket default \<otimes>\<^sub>o swap (inv J aG) = assoc (inv I aF \<otimes>\<^sub>o selfbutterket default)\<close>
     by -
 
   obtain c where *: \<open>selfbutterket (default::'c) \<otimes>\<^sub>o swap (inv J aG) = selfbutterket default \<otimes>\<^sub>o c \<otimes>\<^sub>o selfbutterket default\<close>
     apply atomize_elim
     apply (rule overlapping_tensor)
     using * unfolding assoc_ell2_sandwich sandwich_def
     by auto
 
   have \<open>t1 = ((swap \<otimes>\<^sub>r id) o assoc') t3\<close>
     by (simp add: t3_t1 register_tensor_distrib[unfolded o_def, THEN fun_cong] flip: id_def)
   also have \<open>\<dots> = ((swap \<otimes>\<^sub>r id) o assoc' o (id \<otimes>\<^sub>r swap)) (selfbutterket (default::'c) \<otimes>\<^sub>o swap (inv J aG))\<close>
     unfolding t3' by auto
   also have \<open>\<dots> = ((swap \<otimes>\<^sub>r id) o assoc' o (id \<otimes>\<^sub>r swap)) (selfbutterket default \<otimes>\<^sub>o c \<otimes>\<^sub>o selfbutterket default)\<close>
     unfolding * by simp
   also have \<open>\<dots> = selfbutterket default \<otimes>\<^sub>o c\<close>
     apply (simp del: tensor_butterfly)
     by (simp add: default_prod_def)
   finally have \<open>t1 = selfbutterket default \<otimes>\<^sub>o c\<close>
     by -
 
   then show ?thesis
     apply (auto intro!: exI[of _ c] simp: regular_register_def t1_def)
     by (metis \<open>bij ((F;G);complement (F;G))\<close> bij_inv_eq_iff)
 qed
 
 lemma regular_register_comp: \<open>regular_register (F o G)\<close> if \<open>regular_register F\<close> \<open>regular_register G\<close>
 proof -
   have [simp]: \<open>register F\<close> \<open>register G\<close>
     using regular_register_def that by blast+
   from that obtain a where a: \<open>(F; complement F) (selfbutterket default \<otimes>\<^sub>o a) = selfbutterket default\<close>
     unfolding regular_register_def by metis
   from that obtain b where b: \<open>(G; complement G) (selfbutterket default \<otimes>\<^sub>o b) = selfbutterket default\<close>
     unfolding regular_register_def by metis
   have \<open>complements (F o G) (complement F; F o complement G)\<close>
     by (simp add: complements_chain)
   then have \<open>equivalent_registers (complement F; F o complement G) (complement (F o G))\<close>
     using complement_unique by blast
   then obtain J where [simp]: \<open>iso_register J\<close> and 1: \<open>(complement F; F o complement G) o J = (complement (F o G))\<close>
     using equivalent_registers_def by blast
   have [simp]: \<open>register J\<close>
     by (simp add: iso_register_is_register)
 
   define c where \<open>c = inv J (a \<otimes>\<^sub>o b)\<close>
 
   have \<open>((F o G); complement (F o G)) (selfbutterket default \<otimes>\<^sub>o c) = ((F o G); (complement F; F o complement G)) (selfbutterket default \<otimes>\<^sub>o J c)\<close>
     by (auto simp flip: 1 simp: register_pair_apply)
   also have \<open>\<dots> = ((F o (G; complement G); complement F) o assoc' o (id \<otimes>\<^sub>r swap)) (selfbutterket default \<otimes>\<^sub>o J c)\<close>
     apply (subst register_comp_pair[symmetric])
       apply auto[2]
     apply (subst pair_o_assoc')
        apply auto[3]
     apply (subst pair_o_tensor)
     by auto
   also have \<open>\<dots> = ((F o (G; complement G); complement F) o assoc') (selfbutterket default \<otimes>\<^sub>o swap (J c))\<close>
     by auto
   also have \<open>\<dots> = ((F o (G; complement G); complement F) o assoc') (selfbutterket default \<otimes>\<^sub>o (b \<otimes>\<^sub>o a))\<close>
     unfolding c_def apply (subst surj_f_inv_f[where f=J])
      apply (meson \<open>iso_register J\<close> bij_betw_inv_into_right iso_register_inv_comp1 iso_register_inv_comp2 iso_tuple_UNIV_I o_bij surj_iff_all)
     by auto
   also have \<open>\<dots> = (F \<circ> (G;complement G);complement F) ((selfbutterket default \<otimes>\<^sub>o b) \<otimes>\<^sub>o a)\<close>
     by (simp add: assoc'_apply)
   also have \<open>\<dots> = (F; complement F) ((G;complement G) (selfbutterket default \<otimes>\<^sub>o b) \<otimes>\<^sub>o a)\<close>
     by (simp add: register_pair_apply')
   also have \<open>\<dots> = selfbutterket default\<close>
     by (auto simp: a b) 
   finally have \<open>(F \<circ> G;complement (F \<circ> G)) (selfbutterket default \<otimes>\<^sub>o c) = selfbutterket default\<close>
     by -
   then show ?thesis
     using \<open>register F\<close> \<open>register G\<close> register_comp regular_register_def by blast
 qed
 
 lemma regular_iso_register:
   assumes \<open>regular_register F\<close>
   assumes [register]: \<open>iso_register F\<close>
   shows \<open>F (selfbutterket default) = selfbutterket default\<close>
 proof -
   from assms(1) obtain a where a: \<open>(F;complement F) (selfbutterket default \<otimes>\<^sub>o a) = selfbutterket default\<close>
     using regular_register_def by blast
 
   let ?u = \<open>empty_var :: (unit ell2 \<Rightarrow>\<^sub>C\<^sub>L unit ell2) \<Rightarrow> _\<close>
   have \<open>is_unit_register ?u\<close> and \<open>is_unit_register (complement F)\<close>
     by auto
   then have \<open>equivalent_registers (complement F) ?u\<close>
     using unit_register_unique by blast
   then obtain I where \<open>iso_register I\<close> and \<open>complement F = ?u o I\<close>
     by (metis \<open>is_unit_register (complement F)\<close> equivalent_registers_def is_unit_register_empty_var unit_register_unique)
   have \<open>selfbutterket default = (F; ?u o I) (selfbutterket default \<otimes>\<^sub>o a)\<close>
     using \<open>complement F = empty_var \<circ> I\<close> a by presburger
   also have \<open>\<dots> = (F; ?u) (selfbutterket default \<otimes>\<^sub>o I a)\<close>
     by (metis Laws_Quantum.register_pair_apply \<open>complement F = empty_var \<circ> I\<close> \<open>equivalent_registers (complement F) empty_var\<close> assms(2) comp_apply complement_is_complement complements_def equivalent_complements iso_register_is_register)
   also have \<open>\<dots> = (F; ?u) (selfbutterket default \<otimes>\<^sub>o (one_dim_iso (I a) *\<^sub>C id_cblinfun))\<close>
     by simp
   also have \<open>\<dots> = one_dim_iso (I a) *\<^sub>C (F; ?u) (selfbutterket default \<otimes>\<^sub>o id_cblinfun)\<close>
     by (simp add: Axioms_Quantum.register_pair_apply empty_var_def iso_register_is_register)
   also have \<open>\<dots> = one_dim_iso (I a) *\<^sub>C F (selfbutterket default)\<close>
     by (auto simp: register_pair_apply iso_register_is_register simp del: id_cblinfun_eq_1)
   finally have F: \<open>one_dim_iso (I a) *\<^sub>C F (selfbutterket default) = selfbutterket default\<close>
     by simp
 
   from F have \<open>one_dim_iso (I a) \<noteq> (0::complex)\<close>
     by (metis butterfly_apply butterfly_scaleC_left complex_vector.scale_eq_0_iff id_cblinfun_eq_1 id_cblinfun_not_0 cinner_ket_same ket_nonzero one_dim_iso_of_one one_dim_iso_of_zero')
 
   have \<open>selfbutterket default = one_dim_iso (I a) *\<^sub>C F (selfbutterket default)\<close>
     using F by simp
   also have \<open>\<dots> = one_dim_iso (I a) *\<^sub>C F (selfbutterket default o\<^sub>C\<^sub>L selfbutterket default)\<close>
     by auto
   also have \<open>\<dots> = one_dim_iso (I a) *\<^sub>C (F (selfbutterket default) o\<^sub>C\<^sub>L F (selfbutterket default))\<close>
     by (simp add: assms(2) iso_register_is_register register_mult)
   also have \<open>\<dots> = one_dim_iso (I a) *\<^sub>C ((selfbutterket default /\<^sub>C one_dim_iso (I a)) o\<^sub>C\<^sub>L (selfbutterket default /\<^sub>C one_dim_iso (I a)))\<close>
     by (metis (no_types, lifting) F \<open>one_dim_iso (I a) \<noteq> 0\<close> complex_vector.scale_left_imp_eq inverse_1 left_inverse scaleC_scaleC zero_neq_one)
   also have \<open>\<dots> = one_dim_iso (I a) *\<^sub>C selfbutterket default\<close>
     by (smt (verit, best) butterfly_comp_butterfly calculation cblinfun_compose_scaleC_left cblinfun_compose_scaleC_right complex_vector.scale_cancel_left cinner_ket_same left_inverse scaleC_one scaleC_scaleC)
   finally have \<open>one_dim_iso (I a) = (1::complex)\<close>
     by (metis butterfly_0_left butterfly_apply complex_vector.scale_cancel_right cinner_ket_same ket_nonzero scaleC_one)
   with F show \<open>F (selfbutterket default) = selfbutterket default\<close>
     by simp
 qed
 
 lemma pure_state_nested:
   assumes [simp]: \<open>compatible F G\<close>
   assumes \<open>regular_register H\<close>
   assumes \<open>iso_register H\<close>
   shows \<open>pure_state (F;G) (pure_state H h \<otimes>\<^sub>s g) = pure_state ((F o H);G) (h \<otimes>\<^sub>s g)\<close>
 proof -
   note [[simproc del: Laws_Quantum.compatibility_warn]]
   have [simp]: \<open>register H\<close>
     by (meson assms(3) iso_register_is_register)
   have [simp]: \<open>H (selfbutterket default) = selfbutterket default\<close>
     apply (rule regular_iso_register)
     using assms by auto
   have 1: \<open>pure_state_target_vector H (ket default) = ket default\<close>
     apply (rule pure_state_target_vector_ket_default)
     apply auto
     by (metis (no_types, lifting) cinner_ket_same rangeI scaleC_one)
 
   have \<open>butterfly (pure_state H h) (ket default) = butterfly (H (butterfly h (ket default)) *\<^sub>V ket default) (ket default)\<close>
     by (simp add: pure_state'_def 1)
   also have \<open>\<dots> = H (butterfly h (ket default)) o\<^sub>C\<^sub>L selfbutterket default\<close>
-    by (metis (no_types, hide_lams) adj_cblinfun_compose butterfly_adjoint butterfly_comp_cblinfun double_adj)
+    by (metis (no_types, opaque_lifting) adj_cblinfun_compose butterfly_adjoint butterfly_comp_cblinfun double_adj)
   also have \<open>\<dots> = H (butterfly h (ket default)) o\<^sub>C\<^sub>L H (selfbutterket default)\<close>
     by simp
   also have \<open>\<dots> = H (butterfly h (ket default) o\<^sub>C\<^sub>L selfbutterket default)\<close>
     by (meson \<open>register H\<close> register_mult)
   also have \<open>\<dots> = H (butterfly h (ket default))\<close>
     by auto
   finally have 2: \<open>butterfly (pure_state H h) (ket default) = H (butterfly h (ket default))\<close>
     by simp
 
   show ?thesis
     apply (rule pure_state_eqI)
     using 1 2
     by (auto simp: register_pair_butterfly_tensor compatible_ac_rules default_prod_def simp flip: tensor_ell2_ket)
 qed
 
 lemma state_apply1: 
   assumes [register]: \<open>compatible F G\<close>
   shows \<open>F U *\<^sub>V (F \<psi> \<otimes>\<^sub>p G \<phi>) = (F (U \<psi>) \<otimes>\<^sub>p G \<phi>)\<close>
 proof -
   have [register]: \<open>compatible F G\<close>
     using assms(1) complements_def by blast
   have \<open>F U *\<^sub>V (F \<psi> \<otimes>\<^sub>p G \<phi>) = (F;G) (U \<otimes>\<^sub>o id_cblinfun) *\<^sub>V (F \<psi> \<otimes>\<^sub>p G \<phi>)\<close>
     apply (subst register_pair_apply)
     by auto
   also have \<open>\<dots> = (F (U \<psi>) \<otimes>\<^sub>p G \<phi>)\<close>
     unfolding pure_state'_def 
     by (auto simp: register_mult' cblinfun_comp_butterfly tensor_op_ell2)
   finally show ?thesis
     by -
 qed
 
 lemma Fst_regular[simp]: \<open>regular_register Fst\<close>
   apply (rule regular_registerI[where a=\<open>selfbutterket default\<close> and G=Snd])
   by (auto simp: pair_Fst_Snd default_prod_def)
 
 lemma Snd_regular[simp]: \<open>regular_register Snd\<close>
   apply (rule regular_registerI[where a=\<open>selfbutterket default\<close> and G=Fst])
     apply auto[2]
   apply (auto simp only: default_prod_def swap_apply simp flip: swap_def)
   by auto
 
 lemma id_regular[simp]: \<open>regular_register id\<close>
   apply (rule regular_registerI[where G=unit_register and a=id_cblinfun])
   by (auto simp: register_pair_apply)
 
 lemma swap_regular[simp]: \<open>regular_register swap\<close>
   by (auto intro!: regular_register_pair simp: swap_def)
 
 lemma assoc_regular[simp]: \<open>regular_register assoc\<close>
   by (auto intro!: regular_register_pair regular_register_comp simp: assoc_def)
 
 lemma assoc'_regular[simp]: \<open>regular_register assoc'\<close>
   by (auto intro!: regular_register_pair regular_register_comp simp: assoc'_def)
 
 lemma cspan_pure_state': 
   assumes \<open>iso_register F\<close>
   assumes \<open>cspan (g ` X) = UNIV\<close>
   assumes \<eta>_cond: \<open>F (selfbutter \<eta>) *\<^sub>V pure_state_target_vector F \<eta> \<noteq> 0\<close>
   shows \<open>cspan ((\<lambda>z. pure_state' F (g z) \<eta>) ` X) = UNIV\<close>
 proof -
   from iso_register_decomposition[of F]
   obtain U where [simp]: \<open>unitary U\<close> and F: \<open>F = sandwich U\<close>
     using assms(1) by blast
 
   define \<eta>' c where \<open>\<eta>' = pure_state_target_vector F \<eta>\<close> and \<open>c = cinner (U *\<^sub>V \<eta>) \<eta>'\<close>
 
   from \<eta>_cond
   have \<open>c \<noteq> 0\<close>
     by (simp add: \<eta>'_def F sandwich_def c_def cinner_adj_right)
 
   have \<open>cspan ((\<lambda>z. pure_state' F (g z) \<eta>) ` X) = cspan ((\<lambda>z. F (butterfly (g z) \<eta>) *\<^sub>V \<eta>') ` X)\<close>
     by (simp add: \<eta>'_def pure_state'_def)
   also have \<open>\<dots> = cspan ((\<lambda>z. (butterfly (U *\<^sub>V g z) (U *\<^sub>V \<eta>)) *\<^sub>V \<eta>') ` X)\<close>
     by (simp add: F sandwich_def cinner_adj_right)
   also have \<open>\<dots> = cspan ((\<lambda>z. c *\<^sub>C U *\<^sub>V g z) ` X)\<close>
     by (simp add: c_def)
   also have \<open>\<dots> = (\<lambda>z. c *\<^sub>C U *\<^sub>V z) ` cspan (g ` X)\<close>
     apply (subst complex_vector.linear_span_image[symmetric])
     by (auto simp: image_image)
   also have \<open>\<dots> = (\<lambda>z. c *\<^sub>C U *\<^sub>V z) ` UNIV\<close>
     using assms(2) by presburger
   also have \<open>\<dots> = UNIV\<close>
     apply (rule surjI[where f=\<open>\<lambda>z. (U* *\<^sub>V z) /\<^sub>C c\<close>])
     using \<open>c \<noteq> 0\<close> by (auto simp flip: cblinfun_apply_cblinfun_compose)
   finally show ?thesis
     by -
 qed
 
 lemma cspan_pure_state: 
   assumes [simp]: \<open>iso_register F\<close>
   assumes \<open>cspan (g ` X) = UNIV\<close>
   shows \<open>cspan ((\<lambda>z. pure_state F (g z)) ` X) = UNIV\<close>
   apply (rule cspan_pure_state')
   using assms apply auto[2]
   apply (rule pure_state_target_vector_correct)
   by (auto simp: iso_register_is_register)
 
 lemma pure_state_bounded_clinear:
   assumes [register]: \<open>compatible F G\<close>
   shows \<open>bounded_clinear (\<lambda>\<psi>. (F \<psi> \<otimes>\<^sub>p G \<phi>))\<close>
 proof -
   have [bounded_clinear]: \<open>bounded_clinear (F;G)\<close>
     using assms pair_is_register register_bounded_clinear by blast
   show ?thesis
     unfolding pure_state'_def
     by (auto intro!: bounded_linear_intros)
 qed
 
 lemma pure_state_bounded_clinear_right:
   assumes [register]: \<open>compatible F G\<close>
   shows \<open>bounded_clinear (\<lambda>\<phi>. (F \<psi> \<otimes>\<^sub>p G \<phi>))\<close>
 proof -
   have [bounded_clinear]: \<open>bounded_clinear (F;G)\<close>
     using assms pair_is_register register_bounded_clinear by blast
   show ?thesis
     unfolding pure_state'_def
     by (auto intro!: bounded_linear_intros)
 qed
 
 lemma pure_state_clinear:
   assumes [register]: \<open>compatible F G\<close>
   shows \<open>clinear (\<lambda>\<psi>. (F \<psi> \<otimes>\<^sub>p G \<phi>))\<close>
   using assms bounded_clinear.clinear pure_state_bounded_clinear by blast
 
 method pure_state_flatten_nested =
   (subst pure_state_nested, (auto; fail)[3])+
 
 text \<open>The following method \<open>pure_state_eq\<close> tries to solve a equality where both sides are of the form
   \<open>F\<^sub>1(\<psi>\<^sub>1) \<otimes>\<^sub>p F\<^sub>2(\<psi>\<^sub>2) \<otimes>\<^sub>p \<dots> \<otimes>\<^sub>p F\<^sub>n(\<psi>\<^sub>n)\<close> by reordering the registers and unfolding nested register pairs.
   (For the unfolding of nested pairs, it is necessary that the corresponding \<^term>\<open>compatible F G\<close> facts are provable by the simplifier.)
 
   If the some of the pure states \<^term>\<open>\<psi>\<^sub>i\<close> themselves are \<open>\<otimes>\<^sub>p\<close>-tensors, they will be flattened if possible. 
   (If all necessary conditions can be proven, such as \<open>regular_register\<close> etc.)
 
   The method may either succeed, fail, or reduce the equality to a hopefully simpler one.\<close>
 
 method pure_state_eq =
   (pure_state_flatten_nested?,
     rule pure_state_eqI;
     auto simp: register_pair_butterfly_tensor compatible_ac_rules default_prod_def
     simp flip: tensor_ell2_ket)
 
 lemma example:
   fixes F :: \<open>bit update \<Rightarrow> 'c::{finite,default} update\<close>
     and G :: \<open>bit update \<Rightarrow> 'c update\<close>
   assumes [register]: \<open>compatible F G\<close>
   shows  \<open>(F;G) CNOT o\<^sub>C\<^sub>L (G;F) CNOT o\<^sub>C\<^sub>L (F;G) CNOT = (F;G) swap_ell2\<close>
 proof -
   define Z where \<open>Z = complement (F;G)\<close>
   then have [register]: \<open>compatible Z F\<close> \<open>compatible Z G\<close>
     using assms compatible_complement_pair1 compatible_complement_pair2 compatible_sym by blast+
 
   have [simp]: \<open>iso_register (F;(G;Z))\<close>
     using Z_def assms complements_complement_pair complements_def by blast
 
   have eq1: \<open>((F;G) CNOT o\<^sub>C\<^sub>L (G;F) CNOT o\<^sub>C\<^sub>L (F;G) CNOT) *\<^sub>V (F(ket f) \<otimes>\<^sub>p G(ket g) \<otimes>\<^sub>p Z(ket z))
            = (F;G) swap_ell2 *\<^sub>V (F(ket f) \<otimes>\<^sub>p G(ket g) \<otimes>\<^sub>p Z(ket z))\<close> for f g z
   proof -
     have \<open>(F(ket f) \<otimes>\<^sub>p G(ket g) \<otimes>\<^sub>p Z(ket z)) = ((F;G) (ket f \<otimes>\<^sub>s ket g) \<otimes>\<^sub>p Z(ket z))\<close>
       by pure_state_eq
     also have \<open>(F;G) CNOT *\<^sub>V \<dots> = ((F;G) (ket f \<otimes>\<^sub>s ket (g+f)) \<otimes>\<^sub>p Z(ket z))\<close>
       apply (subst state_apply1) by auto
     also have \<open>\<dots> = ((G;F) (ket (g+f) \<otimes>\<^sub>s ket f) \<otimes>\<^sub>p Z(ket z))\<close>
       by pure_state_eq
     also have \<open>(G;F) CNOT *\<^sub>V \<dots> = ((G;F) (ket (g+f) \<otimes>\<^sub>s ket g) \<otimes>\<^sub>p Z ket z)\<close>
       apply (subst state_apply1) by auto
     also have \<open>\<dots> = ((F;G) (ket g \<otimes>\<^sub>s ket (g+f)) \<otimes>\<^sub>p Z ket z)\<close>
       by pure_state_eq
     also have \<open>(F;G) CNOT *\<^sub>V \<dots> = ((F;G) ket g \<otimes>\<^sub>s ket f \<otimes>\<^sub>p Z ket z)\<close>
-      apply (subst state_apply1) by auto
+      apply (subst state_apply1)
+      apply simp
+      using add_right_imp_eq by fastforce
     also have \<open>\<dots> = (F(ket g) \<otimes>\<^sub>p G(ket f) \<otimes>\<^sub>p Z(ket z))\<close>
       by pure_state_eq
     finally have 1: \<open>((F;G) CNOT o\<^sub>C\<^sub>L (G;F) CNOT o\<^sub>C\<^sub>L (F;G) CNOT) *\<^sub>V (F(ket f) \<otimes>\<^sub>p G(ket g) \<otimes>\<^sub>p Z(ket z)) = (F(ket g) \<otimes>\<^sub>p G(ket f) \<otimes>\<^sub>p Z(ket z))\<close>
       by auto
 
     have \<open>(F(ket f) \<otimes>\<^sub>p G(ket g) \<otimes>\<^sub>p Z(ket z)) = ((F;G) (ket f \<otimes>\<^sub>s ket g) \<otimes>\<^sub>p Z(ket z))\<close>
       by pure_state_eq
     also have \<open>(F;G) swap_ell2 *\<^sub>V \<dots> = ((F;G) (ket g \<otimes>\<^sub>s ket f) \<otimes>\<^sub>p Z(ket z))\<close>
       by (auto simp: state_apply1 swap_ell2_tensor simp del: tensor_ell2_ket)
     also have \<open>\<dots> = (F(ket g) \<otimes>\<^sub>p G(ket f) \<otimes>\<^sub>p Z(ket z))\<close>
       by pure_state_eq
     finally have 2: \<open>(F;G) swap_ell2 *\<^sub>V (F(ket f) \<otimes>\<^sub>p G(ket g) \<otimes>\<^sub>p Z(ket z)) = (F(ket g) \<otimes>\<^sub>p G(ket f) \<otimes>\<^sub>p Z(ket z))\<close>
       by -
 
     from 1 2 show ?thesis
       by simp
   qed
 
   then have eq1: \<open>((F;G) CNOT o\<^sub>C\<^sub>L (G;F) CNOT o\<^sub>C\<^sub>L (F;G) CNOT) *\<^sub>V \<psi>
            = (F;G) swap_ell2 *\<^sub>V \<psi>\<close> if \<open>\<psi> \<in> {(F(ket f) \<otimes>\<^sub>p G(ket g) \<otimes>\<^sub>p Z(ket z))| f g z. True}\<close> for \<psi>
     using that by auto
 
   moreover have \<open>cspan {(F(ket f) \<otimes>\<^sub>p G(ket g) \<otimes>\<^sub>p Z(ket z))| f g z. True} = UNIV\<close>
     apply (simp only: double_exists setcompr_eq_image full_SetCompr_eq)
     apply simp
     apply (rule cspan_pure_state)
     by auto
 
   ultimately show ?thesis
     using cblinfun_eq_on_UNIV_span by blast
 qed
 
 end
diff --git a/thys/Registers/Quantum.thy b/thys/Registers/Quantum.thy
--- a/thys/Registers/Quantum.thy
+++ b/thys/Registers/Quantum.thy
@@ -1,132 +1,142 @@
 section \<open>Quantum mechanics basics\<close>
 
 theory Quantum
   imports
     Finite_Tensor_Product
     "HOL-Library.Z2"
     Jordan_Normal_Form.Matrix_Impl 
     Real_Impl.Real_Impl
     "HOL-Library.Code_Target_Numeral"
 begin
 
 type_synonym ('a,'b) matrix = \<open>('a ell2, 'b ell2) cblinfun\<close>
 
 subsection \<open>Basic quantum states\<close>
 
 subsubsection \<open>EPR pair\<close>
 
 definition "vector_\<beta>00 = vec_of_list [ 1/sqrt 2::complex, 0, 0, 1/sqrt 2 ]"
 definition \<beta>00 :: \<open>(bit\<times>bit) ell2\<close> where [code del]: "\<beta>00 = basis_enum_of_vec vector_\<beta>00"
 lemma vec_of_basis_enum_\<beta>00[simp]: "vec_of_basis_enum \<beta>00 = vector_\<beta>00"
   by (auto simp add: \<beta>00_def vector_\<beta>00_def)
 lemma vec_of_ell2_\<beta>00[simp, code]: "vec_of_ell2 \<beta>00 = vector_\<beta>00"
   by (simp add: vec_of_ell2_def)
 
 lemma norm_\<beta>00[simp]: "norm \<beta>00 = 1"
   by eval
 
 subsubsection \<open>Ket plus\<close>
 
 definition "vector_ketplus = vec_of_list [ 1/sqrt 2::complex, 1/sqrt 2 ]"
 definition ketplus :: \<open>bit ell2\<close> ("|+\<rangle>") where [code del]: \<open>ketplus = basis_enum_of_vec vector_ketplus\<close>
 lemma vec_of_basis_enum_ketplus[simp]: "vec_of_basis_enum ketplus = vector_ketplus"
   by (auto simp add: ketplus_def vector_ketplus_def)
 lemma vec_of_ell2_ketplus[simp, code]: "vec_of_ell2 ketplus = vector_ketplus"
   by (simp add: vec_of_ell2_def)
 
 subsection \<open>Basic quantum gates\<close>
 
 subsubsection \<open>Pauli X\<close>
 
 definition "matrix_pauliX = mat_of_rows_list 2 [ [0::complex, 1], [1, 0] ]"
 definition pauliX :: \<open>(bit, bit) matrix\<close> where [code del]: "pauliX = cblinfun_of_mat matrix_pauliX"
 lemma [simp, code]: "mat_of_cblinfun pauliX = matrix_pauliX"
   apply (auto simp add: pauliX_def matrix_pauliX_def)
   apply (subst cblinfun_of_mat_inverse)
   by (auto)
 
+derive (eq) ceq bit
+
+instantiation bit :: ccompare begin
+definition "CCOMPARE(bit) = Some (\<lambda>b1 b2. case (b1, b2) of (0, 0) \<Rightarrow> order.Eq | (0, 1) \<Rightarrow> order.Lt | (1, 0) \<Rightarrow> order.Gt | (1, 1) \<Rightarrow> order.Eq)"
+instance 
+  by intro_classes(unfold_locales; auto simp add: ccompare_bit_def split!: bit.splits)
+end
+
+derive (dlist) set_impl bit
+
 lemma pauliX_adjoint[simp]: "pauliX* = pauliX"
   by eval
 lemma pauliXX[simp]: "pauliX o\<^sub>C\<^sub>L pauliX = id_cblinfun"
   by eval
 
 subsubsection \<open>Pauli Z\<close>
 
 definition "matrix_pauliZ = mat_of_rows_list 2 [ [1::complex, 0], [0, -1] ]"
 definition pauliZ :: \<open>(bit, bit) matrix\<close> where [code del]: "pauliZ = cblinfun_of_mat matrix_pauliZ"
 lemma [simp, code]: "mat_of_cblinfun pauliZ = matrix_pauliZ"
   apply (auto simp add: pauliZ_def matrix_pauliZ_def)
   apply (subst cblinfun_of_mat_inverse)
   by (auto)
 lemma pauliZ_adjoint[simp]: "pauliZ* = pauliZ"
   by eval
 lemma pauliZZ[simp]: "pauliZ o\<^sub>C\<^sub>L pauliZ = id_cblinfun"
   by eval
 
 
 subsubsection Hadamard
 
 definition "matrix_hadamard = mat_of_rows_list 2 [ [1/sqrt 2::complex, 1/sqrt 2], [1/sqrt 2, -1/sqrt 2] ]"
 definition hadamard :: \<open>(bit,bit) matrix\<close> where [code del]: "hadamard = cblinfun_of_mat matrix_hadamard"
 
 lemma [simp, code]: "mat_of_cblinfun hadamard = matrix_hadamard"
   apply (auto simp add: hadamard_def matrix_hadamard_def)
   apply (subst cblinfun_of_mat_inverse)
   by (auto)
 
 lemma hada_adj[simp]: "hadamard* = hadamard"
   by eval
 
 
 subsubsection CNOT
 
 definition "matrix_CNOT = mat_of_rows_list 4 [ [1::complex,0,0,0], [0,1,0,0], [0,0,0,1], [0,0,1,0] ]"
 definition CNOT :: \<open>(bit*bit, bit*bit) matrix\<close> where [code del]: "CNOT = cblinfun_of_mat matrix_CNOT"
 
 lemma [simp, code]: "mat_of_cblinfun CNOT = matrix_CNOT"
   apply (auto simp add: CNOT_def matrix_CNOT_def)
   apply (subst cblinfun_of_mat_inverse)
   by (auto)
 
 lemma [simp]: "CNOT* = CNOT"
   by eval
 
 lemma cnot_apply[simp]: \<open>CNOT *\<^sub>V ket (i,j) = ket (i,j+i)\<close>
   apply (rule spec[where x=i], rule spec[where x=j])
   by eval
 
 subsubsection \<open>Qubit swap\<close>
 
 
 definition "matrix_Uswap = mat_of_rows_list 4 [ [1::complex, 0, 0, 0], [0,0,1,0], [0,1,0,0], [0,0,0,1] ]"
 definition Uswap :: \<open>(bit\<times>bit, bit\<times>bit) matrix\<close> where
   [code del]: \<open>Uswap = cblinfun_of_mat matrix_Uswap\<close>
 
 lemma mat_of_cblinfun_Uswap[simp, code]: "mat_of_cblinfun Uswap = matrix_Uswap"
   apply (auto simp add: Uswap_def matrix_Uswap_def)
   apply (subst cblinfun_of_mat_inverse)
   by (auto)
 
 lemma dim_col_Uswap[simp]: "dim_col matrix_Uswap = 4"
   unfolding matrix_Uswap_def by simp
 lemma dim_row_Uswap[simp]: "dim_row matrix_Uswap = 4"
   unfolding matrix_Uswap_def by simp
 lemma Uswap_adjoint[simp]: "Uswap* = Uswap"
   by eval
 lemma Uswap_involution[simp]: "Uswap o\<^sub>C\<^sub>L Uswap = id_cblinfun"
   by eval
 lemma unitary_Uswap[simp]: "unitary Uswap"
   unfolding unitary_def by simp
 
 lemma Uswap_apply[simp]: \<open>Uswap *\<^sub>V s \<otimes>\<^sub>s t = t \<otimes>\<^sub>s s\<close>
   apply (rule clinear_equal_ket[where f=\<open>\<lambda>s. Uswap *\<^sub>V s \<otimes>\<^sub>s t\<close>, THEN fun_cong])
     apply (simp add: cblinfun.add_right clinearI tensor_ell2_add1 tensor_ell2_scaleC1)
    apply (simp add: clinear_tensor_ell21)
   apply (rule clinear_equal_ket[where f=\<open>\<lambda>t. Uswap *\<^sub>V _ \<otimes>\<^sub>s t\<close>, THEN fun_cong])
     apply (simp add: cblinfun.add_right clinearI tensor_ell2_add2 tensor_ell2_scaleC2)
    apply (simp add: clinear_tensor_ell22)
   apply (rule basis_enum_eq_vec_of_basis_enumI)
   apply (simp add: mat_of_cblinfun_cblinfun_apply vec_of_basis_enum_ket)
   by (case_tac i; case_tac ia; hypsubst_thin; normalization)
 
 end