(*  Title:      HOL/IOA/IOA.thy
    Author:     Tobias Nipkow & Konrad Slind
    Copyright   1994  TU Muenchen
*)

section \<open>The I/O automata of Lynch and Tuttle\<close>

theory IOA
imports Asig
begin

type_synonym 'a seq = "nat => 'a"
type_synonym 'a oseq = "nat => 'a option"
type_synonym ('a, 'b) execution = "'a oseq * 'b seq"
type_synonym ('a, 's) transition = "('s * 'a * 's)"
type_synonym ('a,'s) ioa = "'a signature * 's set * ('a, 's) transition set"

(* IO automata *)

definition state_trans :: "['action signature, ('action,'state)transition set] => bool"
  where "state_trans asig R ==
     (!triple. triple:R --> fst(snd(triple)):actions(asig)) &
     (!a. (a:inputs(asig)) --> (!s1. ? s2. (s1,a,s2):R))"

definition asig_of :: "('action,'state)ioa => 'action signature"
  where "asig_of == fst"

definition starts_of :: "('action,'state)ioa => 'state set"
  where "starts_of == (fst o snd)"

definition trans_of :: "('action,'state)ioa => ('action,'state)transition set"
  where "trans_of == (snd o snd)"

definition IOA :: "('action,'state)ioa => bool"
  where "IOA(ioa) == (is_asig(asig_of(ioa)) &
                (~ starts_of(ioa) = {}) &
                state_trans (asig_of ioa) (trans_of ioa))"

(* Executions, schedules, and traces *)

(* An execution fragment is modelled with a pair of sequences:
   the first is the action options, the second the state sequence.
   Finite executions have None actions from some point on. *)
definition is_execution_fragment :: "[('action,'state)ioa, ('action,'state)execution] => bool"
  where "is_execution_fragment A ex ==
     let act = fst(ex); state = snd(ex)
     in !n a. (act(n)=None --> state(Suc(n)) = state(n)) &
              (act(n)=Some(a) --> (state(n),a,state(Suc(n))):trans_of(A))"

definition executions :: "('action,'state)ioa => ('action,'state)execution set"
  where "executions(ioa) == {e. snd e 0:starts_of(ioa) & is_execution_fragment ioa e}"

definition reachable :: "[('action,'state)ioa, 'state] => bool"
  where "reachable ioa s == (? ex:executions(ioa). ? n. (snd ex n) = s)"

definition invariant :: "[('action,'state)ioa, 'state=>bool] => bool"
  where "invariant A P == (!s. reachable A s --> P(s))"

(* Composition of action signatures and automata *)

consts
  compatible_asigs ::"('a => 'action signature) => bool"
  asig_composition ::"('a => 'action signature) => 'action signature"
  compatible_ioas  ::"('a => ('action,'state)ioa) => bool"
  ioa_composition  ::"('a => ('action, 'state)ioa) =>('action,'a => 'state)ioa"

(* binary composition of action signatures and automata *)

definition compat_asigs ::"['action signature, 'action signature] => bool"
  where "compat_asigs a1 a2 ==
   (((outputs(a1) Int outputs(a2)) = {}) &
    ((internals(a1) Int actions(a2)) = {}) &
    ((internals(a2) Int actions(a1)) = {}))"

definition compat_ioas  ::"[('action,'s)ioa, ('action,'t)ioa] => bool"
  where "compat_ioas ioa1 ioa2 == compat_asigs (asig_of(ioa1)) (asig_of(ioa2))"

definition asig_comp :: "['action signature, 'action signature] => 'action signature"
  where "asig_comp a1 a2 ==
      (((inputs(a1) Un inputs(a2)) - (outputs(a1) Un outputs(a2)),
        (outputs(a1) Un outputs(a2)),
        (internals(a1) Un internals(a2))))"

definition par :: "[('a,'s)ioa, ('a,'t)ioa] => ('a,'s*'t)ioa"  (infixr "||" 10)
  where "(ioa1 || ioa2) ==
     (asig_comp (asig_of ioa1) (asig_of ioa2),
      {pr. fst(pr):starts_of(ioa1) & snd(pr):starts_of(ioa2)},
      {tr. let s = fst(tr); a = fst(snd(tr)); t = snd(snd(tr))
           in (a:actions(asig_of(ioa1)) | a:actions(asig_of(ioa2))) &
              (if a:actions(asig_of(ioa1)) then
                 (fst(s),a,fst(t)):trans_of(ioa1)
               else fst(t) = fst(s))
              &
              (if a:actions(asig_of(ioa2)) then
                 (snd(s),a,snd(t)):trans_of(ioa2)
               else snd(t) = snd(s))})"

(* Filtering and hiding *)

(* Restrict the trace to those members of the set s *)
definition filter_oseq :: "('a => bool) => 'a oseq => 'a oseq"
  where "filter_oseq p s ==
   (%i. case s(i)
         of None => None
          | Some(x) => if p x then Some x else None)"

definition mk_trace :: "[('action,'state)ioa, 'action oseq] => 'action oseq"
  where "mk_trace(ioa) == filter_oseq(%a. a:externals(asig_of(ioa)))"

(* Does an ioa have an execution with the given trace *)
definition has_trace :: "[('action,'state)ioa, 'action oseq] => bool"
  where "has_trace ioa b == (? ex:executions(ioa). b = mk_trace ioa (fst ex))"

definition NF :: "'a oseq => 'a oseq"
  where "NF(tr) == @nf. ? f. mono(f) & (!i. nf(i)=tr(f(i))) &
                    (!j. j ~: range(f) --> nf(j)= None) &
                    (!i. nf(i)=None --> (nf (Suc i)) = None)"

(* All the traces of an ioa *)
definition traces :: "('action,'state)ioa => 'action oseq set"
  where "traces(ioa) == {trace. ? tr. trace=NF(tr) & has_trace ioa tr}"

definition restrict_asig :: "['a signature, 'a set] => 'a signature"
  where "restrict_asig asig actns ==
    (inputs(asig) Int actns, outputs(asig) Int actns,
     internals(asig) Un (externals(asig) - actns))"

definition restrict :: "[('a,'s)ioa, 'a set] => ('a,'s)ioa"
  where "restrict ioa actns ==
    (restrict_asig (asig_of ioa) actns, starts_of(ioa), trans_of(ioa))"

(* Notions of correctness *)

definition ioa_implements :: "[('action,'state1)ioa, ('action,'state2)ioa] => bool"
  where "ioa_implements ioa1 ioa2 ==
  ((inputs(asig_of(ioa1)) = inputs(asig_of(ioa2))) &
     (outputs(asig_of(ioa1)) = outputs(asig_of(ioa2))) &
      traces(ioa1) <= traces(ioa2))"

(* Instantiation of abstract IOA by concrete actions *)

definition rename :: "('a, 'b)ioa => ('c => 'a option) => ('c,'b)ioa"
  where "rename ioa ren ==
    (({b. ? x. Some(x)= ren(b) & x : inputs(asig_of(ioa))},
      {b. ? x. Some(x)= ren(b) & x : outputs(asig_of(ioa))},
      {b. ? x. Some(x)= ren(b) & x : internals(asig_of(ioa))}),
                starts_of(ioa)   ,
     {tr. let s = fst(tr); a = fst(snd(tr));  t = snd(snd(tr))
          in
          ? x. Some(x) = ren(a) & (s,x,t):trans_of(ioa)})"

declare Let_def [simp]

lemmas ioa_projections = asig_of_def starts_of_def trans_of_def
  and exec_rws = executions_def is_execution_fragment_def

lemma ioa_triple_proj:
    "asig_of(x,y,z) = x & starts_of(x,y,z) = y & trans_of(x,y,z) = z"
  apply (simp add: ioa_projections)
  done

lemma trans_in_actions:
  "[| IOA(A); (s1,a,s2):trans_of(A) |] ==> a:actions(asig_of(A))"
  apply (unfold IOA_def state_trans_def actions_def is_asig_def)
  apply (erule conjE)+
  apply (erule allE, erule impE, assumption)
  apply simp
  done

lemma filter_oseq_idemp: "filter_oseq p (filter_oseq p s) = filter_oseq p s"
  apply (simp add: filter_oseq_def)
  apply (rule ext)
  apply (case_tac "s i")
  apply simp_all
  done

lemma mk_trace_thm:
"(mk_trace A s n = None) =
   (s(n)=None | (? a. s(n)=Some(a) & a ~: externals(asig_of(A))))
   &
   (mk_trace A s n = Some(a)) =
    (s(n)=Some(a) & a : externals(asig_of(A)))"
  apply (unfold mk_trace_def filter_oseq_def)
  apply (case_tac "s n")
  apply auto
  done

lemma reachable_0: "s:starts_of(A) ==> reachable A s"
  apply (unfold reachable_def)
  apply (rule_tac x = "(%i. None, %i. s)" in bexI)
  apply simp
  apply (simp add: exec_rws)
  done

lemma reachable_n:
  "!!A. [| reachable A s; (s,a,t) : trans_of(A) |] ==> reachable A t"
  apply (unfold reachable_def exec_rws)
  apply (simp del: bex_simps)
  apply (simp (no_asm_simp) only: split_tupled_all)
  apply safe
  apply (rename_tac ex1 ex2 n)
  apply (rule_tac x = "(%i. if i<n then ex1 i else (if i=n then Some a else None) , %i. if i<Suc n then ex2 i else t)" in bexI)
   apply (rule_tac x = "Suc n" in exI)
   apply (simp (no_asm))
  apply simp
  apply (metis ioa_triple_proj less_antisym)
  done

lemma invariantI:
  assumes p1: "!!s. s:starts_of(A) ==> P(s)"
    and p2: "!!s t a. [|reachable A s; P(s)|] ==> (s,a,t): trans_of(A) --> P(t)"
  shows "invariant A P"
  apply (unfold invariant_def reachable_def Let_def exec_rws)
  apply safe
  apply (rename_tac ex1 ex2 n)
  apply (rule_tac Q = "reachable A (ex2 n) " in conjunct1)
  apply simp
  apply (induct_tac n)
   apply (fast intro: p1 reachable_0)
  apply (erule_tac x = na in allE)
  apply (case_tac "ex1 na", simp_all)
  apply safe
   apply (erule p2 [THEN mp])
    apply (fast dest: reachable_n)+
  done

lemma invariantI1:
 "[| !!s. s : starts_of(A) ==> P(s);
     !!s t a. reachable A s ==> P(s) --> (s,a,t):trans_of(A) --> P(t)
  |] ==> invariant A P"
  apply (blast intro!: invariantI)
  done

lemma invariantE:
  "[| invariant A P; reachable A s |] ==> P(s)"
  apply (unfold invariant_def)
  apply blast
  done

lemma actions_asig_comp:
  "actions(asig_comp a b) = actions(a) Un actions(b)"
  apply (auto simp add: actions_def asig_comp_def asig_projections)
  done

lemma starts_of_par:
  "starts_of(A || B) = {p. fst(p):starts_of(A) & snd(p):starts_of(B)}"
  apply (simp add: par_def ioa_projections)
  done

(* Every state in an execution is reachable *)
lemma states_of_exec_reachable:
  "ex:executions(A) ==> !n. reachable A (snd ex n)"
  apply (unfold reachable_def)
  apply fast
  done

lemma trans_of_par4:
"(s,a,t) : trans_of(A || B || C || D) =
  ((a:actions(asig_of(A)) | a:actions(asig_of(B)) | a:actions(asig_of(C)) |
    a:actions(asig_of(D))) &
   (if a:actions(asig_of(A)) then (fst(s),a,fst(t)):trans_of(A)
    else fst t=fst s) &
   (if a:actions(asig_of(B)) then (fst(snd(s)),a,fst(snd(t))):trans_of(B)
    else fst(snd(t))=fst(snd(s))) &
   (if a:actions(asig_of(C)) then
      (fst(snd(snd(s))),a,fst(snd(snd(t)))):trans_of(C)
    else fst(snd(snd(t)))=fst(snd(snd(s)))) &
   (if a:actions(asig_of(D)) then
      (snd(snd(snd(s))),a,snd(snd(snd(t)))):trans_of(D)
    else snd(snd(snd(t)))=snd(snd(snd(s)))))"
  (*SLOW*)
  apply (simp (no_asm) add: par_def actions_asig_comp prod_eq_iff ioa_projections)
  done

lemma cancel_restrict: "starts_of(restrict ioa acts) = starts_of(ioa) &
              trans_of(restrict ioa acts) = trans_of(ioa) &
              reachable (restrict ioa acts) s = reachable ioa s"
  apply (simp add: is_execution_fragment_def executions_def
    reachable_def restrict_def ioa_projections)
  done

lemma asig_of_par: "asig_of(A || B) = asig_comp (asig_of A) (asig_of B)"
  apply (simp add: par_def ioa_projections)
  done

lemma externals_of_par: "externals(asig_of(A1||A2)) =
   (externals(asig_of(A1)) Un externals(asig_of(A2)))"
  apply (simp add: externals_def asig_of_par asig_comp_def
    asig_inputs_def asig_outputs_def Un_def set_diff_eq)
  apply blast
  done

lemma ext1_is_not_int2:
  "[| compat_ioas A1 A2; a:externals(asig_of(A1))|] ==> a~:internals(asig_of(A2))"
  apply (unfold externals_def actions_def compat_ioas_def compat_asigs_def)
  apply auto
  done

lemma ext2_is_not_int1:
 "[| compat_ioas A2 A1 ; a:externals(asig_of(A1))|] ==> a~:internals(asig_of(A2))"
  apply (unfold externals_def actions_def compat_ioas_def compat_asigs_def)
  apply auto
  done

lemmas ext1_ext2_is_not_act2 = ext1_is_not_int2 [THEN int_and_ext_is_act]
  and ext1_ext2_is_not_act1 = ext2_is_not_int1 [THEN int_and_ext_is_act]

end


subsection \<open>Proving Noninterference\<close>

theory BLP_NI
imports BLP_Monitor "../Noninterference/Noninterference"
begin

context BLP_Monitor
begin

text \<open>We can show that, in a specific sense, a Bell/LaPadula reference monitor satisfies a
noninterference policy.\<close>

text \<open>The lattice of security levels of a Bell/LaPadula policy can be interpreted as a flow policy
in the sense of Goguen-Meseguer: @{text "(l \<leadsto> l') \<longleftrightarrow> (l \<le> l')"}\<close>

definition FP :: "'level rel" where
  "FP = {(l, l'). l \<le> l'}"

text \<open>We now have to define the labeling of actions with security domains/levels. We could label
an action according to the object that is written to or read from, or according to the subject that
performs the action, or even according to a combination of both (i.e. take the supremum of the two
levels).

It turns out that we can show noninterference for each of these choices.

In the following, we choose the labeling according to subject. The intuition is that an observer on
level @{text l} may see the actions (and outputs of those actions) of all users with a clearance of
@{text l} and below, while the observer must not learn anything about actions of users in other
security levels.\<close>

primrec dom :: "('subj, 'obj, 'val) act \<Rightarrow> 'level" where
  "dom (R subj obj) = sc subj"
| "dom (W subj obj val) = sc subj"

sublocale NI init step out FP dom
unfolding FP_def
by (unfold_locales) (auto simp add: refl_on_def trans_def)

notation flow ("_ \<leadsto> _")

text \<open>In order to show that the Bell/LaPadula monitor satisfies noninterference
wrt. this policy, we proceed by using the unwinding theorem.\<close>

text \<open>We choose an unwinding relation for each security level @{text l} so that two states are
equivalent iff they coincide on the values of objects with level @{text l} or below.\<close>

definition view :: "'level \<Rightarrow> ('obj, 'val) state rel" where
  "view l \<equiv> {(s, s'). (\<forall>obj. oc obj \<le> l \<longrightarrow> s obj = s' obj)}"

sublocale View_Partitioning init step out FP dom view
by (unfold_locales)
   (auto simp add: view_def intro!: equivI refl_onI symI transI)

notation view' ("_ \<sim>\<^bsub>_\<^esub> _")

text \<open>With these unwinding relations, we can show noninterference by proving
the unwinding conditions:\<close>

lemma oc: "output_consistent"
unfolding output_consistent_def
proof (intro allI impI)
  fix a s t
  assume "s \<sim>\<^bsub>dom a\<^esub> t"
  then show "out s a = out t a"
    by (cases a) (auto simp add: view_def intro: read_secure)
qed

lemma lr: "locally_respects_FP"
unfolding locally_respects_FP_def
proof (intro allI impI)
  fix s l a
  assume "(dom a, l) \<notin> FP"
  then show "s \<sim>\<^bsub>l\<^esub> (step s a)"
    by (cases a) (auto simp add: view_def intro: write_secure order_trans)
qed

lemma sc: "step_consistent"
unfolding step_consistent_def
proof (intro allI impI, elim conjE)
  fix s t l a
  assume "(dom a) \<leadsto> l"
     and "s \<sim>\<^bsub>l\<^esub> t"
  then show "(step s a) \<sim>\<^bsub>l\<^esub> (step t a)"
    by (cases a) (auto simp add: view_def)
qed

theorem monitor_secure: "NI_secure"
using oc lr sc
by (intro unwinding_theorem)

end

end


(*  Author: Lukas Bulwahn <lukas.bulwahn-at-gmail.com> *)

section \<open>Preliminaries\<close>

theory Preliminaries
imports
  Main
  "HOL-Library.Multiset"
  "HOL-Library.FuncSet"
  "HOL-Combinatorics.Permutations"
  "HOL-ex.Birthday_Paradox"
  Card_Partitions.Card_Partitions
  Bell_Numbers_Spivey.Bell_Numbers
  Card_Multisets.Card_Multisets
  Card_Number_Partitions.Card_Number_Partitions
begin

subsection \<open>Additions to Finite Set Theory\<close>

lemma subset_with_given_card_exists:
  assumes "n \<le> card A"
  shows "\<exists>B \<subseteq> A. card B = n"
using assms proof (induct n)
  case 0
  then show ?case by auto
next
  case (Suc n)
  from this obtain B where "B \<subseteq> A" "card B = n" by auto
  from this \<open>B \<subseteq> A\<close> \<open>card B = n\<close> have "card B < card A"
    using Suc.prems by linarith
  from \<open>Suc n \<le> card A\<close> card.infinite have "finite A" by force
  from this \<open>B \<subseteq> A\<close> finite_subset have "finite B" by blast
  from \<open>card B < card A\<close> \<open>B \<subseteq> A\<close> obtain a where "a \<in> A" "a \<notin> B"
    by (metis less_irrefl subsetI subset_antisym)
  have "insert a B \<subseteq> A" "card (insert a B) = Suc n"
    using \<open>finite B\<close> \<open>a \<in> A\<close> \<open>a \<notin> B\<close> \<open>B \<subseteq> A\<close> \<open>card B = n\<close> by auto
  then show ?case by blast
qed

subsection \<open>Additions to Equiv Relation Theory\<close>

lemmas univ_commute' = univ_commute[unfolded Equiv_Relations.proj_def]

lemma univ_predicate_impl_forall:
  assumes "equiv A R"
  assumes "P respects R"
  assumes "X \<in> A // R"
  assumes "univ P X"
  shows "\<forall>x\<in>X. P x"
proof -
  from assms(1,3) obtain x where "x \<in> X"
    by (metis equiv_class_self quotientE)
  from \<open>x \<in> X\<close> assms(1,3) have "X = R `` {x}"
    by (metis Image_singleton_iff equiv_class_eq quotientE)
  from assms(1,2,4) this show ?thesis
    using equiv_class_eq_iff univ_commute' by fastforce
qed

lemma univ_preserves_predicate:
  assumes "equiv A r"
  assumes "P respects r"
  shows "{x \<in> A. P x} // r = {X \<in> A // r. univ P X}"
proof
  show "{x \<in> A. P x} // r \<subseteq> {X \<in> A // r. univ P X}"
  proof
    fix X
    assume "X \<in> {x \<in> A. P x} // r"
    from this obtain x where "x \<in> {x \<in> A. P x}" and "X = r `` {x}"
      using quotientE by blast
    have "X \<in> A // r"
      using \<open>X = r `` {x}\<close> \<open>x \<in> {x \<in> A. P x}\<close>
      by (auto intro: quotientI)
    moreover have "univ P X"
      using \<open>X = r `` {x}\<close> \<open>x \<in> {x \<in> A. P x}\<close> assms
      by (simp add: proj_def[symmetric] univ_commute)
    ultimately show "X \<in> {X \<in> A // r. univ P X}" by auto
  qed
next
  show "{X \<in> A // r. univ P X} \<subseteq> {x \<in> A. P x} // r"
  proof
    fix X
    assume "X \<in> {X \<in> A // r. univ P X}"
    from this have "X \<in> A // r" and "univ P X" by auto
    from \<open>X \<in> A // r\<close> obtain x where "x \<in> A" and "X = r `` {x}"
      using quotientE by blast
    have "x \<in> {x \<in> A. P x}"
      using \<open>x \<in> A\<close> \<open>X = r `` {x}\<close> \<open>univ P X\<close> assms
      by (simp add: proj_def[symmetric] univ_commute)
    from this show "X \<in> {x \<in> A. P x} // r"
      using \<open>X = r `` {x}\<close> by (auto intro: quotientI)
  qed
qed

lemma Union_quotient_restricted:
  assumes "equiv A r"
  assumes "P respects r"
  shows "\<Union>({x \<in> A. P x} // r) = {x \<in> A. P x}"
proof
  show "\<Union>({x \<in> A. P x} // r) \<subseteq> {x \<in> A. P x}"
  proof
    fix x
    assume "x \<in> \<Union>({x \<in> A. P x} // r)"
    from this obtain X where "x \<in> X" and "X \<in> {x \<in> A. P x} // r" by blast
    from this obtain x' where "X = r `` {x'}" and "x' \<in> {x \<in> A. P x}"
      using quotientE by blast
    from this \<open>x \<in> X\<close> have "x \<in> A"
      using \<open>equiv A r\<close> by (simp add: equiv_class_eq_iff)
    moreover from \<open>X = r `` {x'}\<close> \<open>x \<in> X\<close> \<open>x' \<in> {x \<in> A. P x}\<close> have "P x"
      using \<open>P respects r\<close> congruentD by fastforce
    ultimately show "x \<in> {x \<in> A. P x}" by auto
  qed
next
  show "{x \<in> A. P x} \<subseteq> \<Union>({x \<in> A. P x} // r)"
  proof
    fix x
    assume "x \<in> {x \<in> A. P x}"
    from this have "x \<in> r `` {x}"
      using \<open>equiv A r\<close> equiv_class_self by fastforce
    from \<open>x \<in> {x \<in> A. P x}\<close> have "r `` {x} \<in> {x \<in> A. P x} // r"
      by (auto intro: quotientI)
    from this \<open>x \<in> r `` {x}\<close> show "x \<in> \<Union>({x \<in> A. P x} // r)" by auto
  qed
qed

lemma finite_equiv_implies_finite_carrier:
  assumes "equiv A R"
  assumes "finite (A // R)"
  assumes "\<forall>X \<in> A // R. finite X"
  shows "finite A"
proof -
  from \<open>equiv A R\<close> have "A = \<Union>(A // R)"
    by (simp add: Union_quotient)
  from this \<open>finite (A // R)\<close> \<open>\<forall>X \<in> A // R. finite X\<close> show "finite A"
    using finite_Union by fastforce
qed

lemma finite_quotient_iff:
  assumes "equiv A R"
  shows "finite A \<longleftrightarrow> (finite (A // R) \<and> (\<forall>X \<in> A // R. finite X))"
using assms by (meson equiv_type finite_equiv_class finite_equiv_implies_finite_carrier finite_quotient)

subsubsection \<open>Counting Sets by Splitting into Equivalence Classes\<close>

lemma card_equiv_class_restricted:
  assumes "finite {x \<in> A. P x}"
  assumes "equiv A R"
  assumes "P respects R"
  shows "card {x \<in> A. P x} = sum card ({x \<in> A. P x} // R)"
proof -
  have "card {x \<in> A. P x} = card (\<Union>({x \<in> A. P x} // R))"
    using \<open>equiv A R\<close> \<open>P respects R\<close> by (simp add: Union_quotient_restricted)
  also have "card (\<Union>({x \<in> A. P x} // R)) = (\<Sum>C\<in>{x \<in> A. P x} // R. card C)"
  proof -
    from \<open>finite {x \<in> A. P x}\<close> have "finite ({x \<in> A. P x} // R)"
      using \<open>equiv A R\<close> by (metis finite_imageI proj_image)
    moreover from \<open>finite {x \<in> A. P x}\<close> have "\<forall>C\<in>{x \<in> A. P x} // R. finite C"
      using \<open>equiv A R\<close> \<open>P respects R\<close> Union_quotient_restricted
        Union_upper finite_subset by fastforce
    moreover have "\<forall>C1 \<in> {x \<in> A. P x} // R. \<forall>C2 \<in> {x \<in> A. P x} // R. C1 \<noteq> C2 \<longrightarrow> C1 \<inter> C2 = {}"
      using \<open>equiv A R\<close> quotient_disj
      by (metis (no_types, lifting) mem_Collect_eq quotientE quotientI)
    ultimately show ?thesis
      by (subst card_Union_disjoint) (auto simp: pairwise_def disjnt_def)
  qed
  finally show ?thesis .
qed

lemma card_equiv_class_restricted_same_size:
  assumes "equiv A R"
  assumes "P respects R"
  assumes "\<And>F. F \<in> {x \<in> A. P x} // R \<Longrightarrow> card F = k"
  shows "card {x \<in> A. P x} = k * card ({x \<in> A. P x} // R)"
proof cases
  assume "finite {x \<in> A. P x}"
  have "card {x \<in> A. P x} = sum card ({x \<in> A. P x} // R)"
    using \<open>finite {x \<in> A. P x}\<close> \<open>equiv A R\<close> \<open>P respects R\<close>
    by (simp add: card_equiv_class_restricted)
  also have "sum card ({x \<in> A. P x} // R) = k * card ({x \<in> A. P x} // R)"
    by (simp add: \<open>\<And>F. F \<in> {x \<in> A. P x} // R \<Longrightarrow> card F = k\<close>)
  finally show ?thesis .
next
  assume "infinite {x \<in> A. P x}"
  from this have "infinite (\<Union>({a \<in> A. P a} // R))"
    using \<open>equiv A R\<close> \<open>P respects R\<close> by (simp add: Union_quotient_restricted)
  from this have "infinite ({x \<in> A. P x} // R) \<or> (\<exists>X \<in> {x \<in> A. P x} // R. infinite X)"
    by auto
  from this show ?thesis
  proof
    assume "infinite ({x \<in> A. P x} // R)"
    from this \<open>infinite {x \<in> A. P x}\<close> show ?thesis by simp
  next
    assume "\<exists>X \<in> {x \<in> A. P x} // R. infinite X"
    from this \<open>infinite {x \<in> A. P x}\<close> show ?thesis
      using \<open>\<And>F. F \<in> {x \<in> A. P x} // R \<Longrightarrow> card F = k\<close> card.infinite by auto
  qed
qed

lemma card_equiv_class:
  assumes "finite A"
  assumes "equiv A R"
  shows "card A = sum card (A // R)"
proof -
  have "(\<lambda>x. True) respects R" by (simp add: congruentI)
  from \<open>finite A\<close> \<open>equiv A R\<close> this show ?thesis
    using card_equiv_class_restricted[where P="\<lambda>x. True"] by auto
qed

lemma card_equiv_class_same_size:
  assumes "equiv A R"
  assumes "\<And>F. F \<in> A // R \<Longrightarrow> card F = k"
  shows "card A = k * card (A // R)"
proof -
  have "(\<lambda>x. True) respects R" by (simp add: congruentI)
  from \<open>equiv A R\<close> \<open>\<And>F. F \<in> A // R \<Longrightarrow> card F = k\<close> this show ?thesis
    using card_equiv_class_restricted_same_size[where P="\<lambda>x. True"] by auto
qed

subsection \<open>Additions to FuncSet Theory\<close>

lemma finite_same_card_bij_on_ext_funcset:
  assumes "finite A" "finite B" "card A = card B"
  shows "\<exists>f. f \<in> A \<rightarrow>\<^sub>E B \<and> bij_betw f A B"
proof -
  from assms obtain f' where f': "bij_betw f' A B"
    using finite_same_card_bij by auto
  define f where "\<And>x. f x = (if x \<in> A then f' x else undefined)"
  have "f \<in> A \<rightarrow>\<^sub>E B"
    using f' unfolding f_def by (auto simp add: bij_betwE)
  moreover have "bij_betw f A B"
  proof -
    have "bij_betw f' A B \<longleftrightarrow> bij_betw f A B"
      unfolding f_def by (auto intro!: bij_betw_cong)
    from this \<open>bij_betw f' A B\<close> show ?thesis by auto
  qed
  ultimately show ?thesis by auto
qed

lemma card_extensional_funcset:
  assumes "finite A"
  shows "card (A \<rightarrow>\<^sub>E B) = card B ^ card A"
using assms by (simp add: card_PiE prod_constant)

lemma bij_betw_implies_inj_on_and_card_eq:
  assumes "finite B"
  assumes "f \<in> A \<rightarrow>\<^sub>E B"
  shows "bij_betw f A B \<longleftrightarrow> inj_on f A \<and> card A = card B"
proof
  assume "bij_betw f A B"
  from this show "inj_on f A \<and> card A = card B"
    by (simp add: bij_betw_imp_inj_on bij_betw_same_card)
next
  assume "inj_on f A \<and> card A = card B"
  from this have "inj_on f A" and "card A = card B" by auto
  from \<open>f \<in> A \<rightarrow>\<^sub>E B\<close> have "f ` A \<subseteq> B" by auto
  from \<open>inj_on f A\<close> have "card (f ` A) = card A" by (simp add: card_image)
  from \<open>f ` A \<subseteq> B\<close> \<open>card A = card B\<close> this have "f ` A = B"
    by (simp add: \<open>finite B\<close> card_subset_eq)
  from \<open>inj_on f A\<close> this show "bij_betw f A B" by (rule bij_betw_imageI)
qed

lemma bij_betw_implies_surj_on_and_card_eq:
  assumes "finite A"
  assumes "f \<in> A \<rightarrow>\<^sub>E B"
  shows "bij_betw f A B \<longleftrightarrow> f ` A = B \<and> card A = card B"
proof
  assume "bij_betw f A B"
  show "f ` A = B \<and> card A = card B"
    using \<open>bij_betw f A B\<close> bij_betw_imp_surj_on bij_betw_same_card by blast
next
  assume "f ` A = B \<and> card A = card B"
  from this have "f ` A = B" and "card A = card B" by auto
  from this have "inj_on f A"
    by (simp add: \<open>finite A\<close> inj_on_iff_eq_card)
  from this \<open>f ` A = B\<close> show "bij_betw f A B" by (rule bij_betw_imageI)
qed

subsection \<open>Additions to Permutations Theory\<close>

lemma
  assumes "f \<in> A \<rightarrow>\<^sub>E B" "f ` A = B"
  assumes "p permutes B" "(\<forall>x. f' x = p (f x))"
  shows "(\<lambda>b. {x\<in>A. f x = b}) ` B = (\<lambda>b. {x\<in>A. f' x = b}) ` B"
proof
  show "(\<lambda>b. {x \<in> A. f x = b}) ` B \<subseteq> (\<lambda>b. {x \<in> A. f' x = b}) ` B"
  proof
    fix X
    assume "X \<in> (\<lambda>b. {x \<in> A. f x = b}) ` B"
    from this obtain b where X_eq: "X = {x \<in> A. f x = b}" and "b \<in> B" by blast
    from assms(3, 4) have "\<And>x. f x = b \<longleftrightarrow> f' x = p b" by (metis permutes_def)
    from \<open>p permutes B\<close> X_eq this have "X = {x \<in> A. f' x = p b}"
      using Collect_cong by auto
    moreover from \<open>b \<in> B\<close> \<open>p permutes B\<close> have "p b \<in> B"
      by (simp add: permutes_in_image)
    ultimately show "X \<in> (\<lambda>b. {x \<in> A. f' x = b}) ` B" by blast
  qed
next
  show "(\<lambda>b. {x \<in> A. f' x = b}) ` B \<subseteq> (\<lambda>b. {x \<in> A. f x = b}) ` B"
  proof
    fix X
    assume "X \<in> (\<lambda>b. {x \<in> A. f' x = b}) ` B"
    from this obtain b where X_eq: "X = {x \<in> A. f' x = b}" and "b \<in> B" by blast
    from assms(3, 4) have "\<And>x. f' x = b \<longleftrightarrow> f x = inv p b"
      by (auto simp add: permutes_inverses(1, 2))
    from \<open>p permutes B\<close> X_eq this have "X = {x \<in> A. f x = inv p b}"
      using Collect_cong by auto
    moreover from \<open>b \<in> B\<close> \<open>p permutes B\<close> have "inv p b \<in> B"
      by (simp add: permutes_in_image permutes_inv)
    ultimately show "X \<in> (\<lambda>b. {x \<in> A. f x = b}) ` B" by blast
  qed
qed

subsection \<open>Additions to List Theory\<close>

text \<open>
The theorem @{thm [source] card_lists_length_eq} contains the superfluous assumption @{term "finite A"}.
Here, we derive that fact without that unnecessary assumption.
\<close>

lemma lists_length_eq_Suc_eq_image_Cons:
  "{xs. set xs \<subseteq> A \<and> length xs = Suc n} = (\<lambda>(x, xs). x#xs) ` (A \<times> {xs. set xs \<subseteq> A \<and> length xs = n})"
  (is "?A = ?B")
proof
  show "?A \<subseteq> ?B"
  proof
    fix xs
    assume "xs \<in> ?A"
    from this show "xs \<in> ?B" by (cases xs) auto
  qed
next
  show "?B \<subseteq> ?A" by auto
qed

lemma lists_length_eq_Suc_eq_empty_iff:
  "{xs. set xs \<subseteq> A \<and> length xs = Suc n} = {} \<longleftrightarrow> A = {}"
proof (induct n)
  case 0
  have "{xs. set xs \<subseteq> A \<and> length xs = Suc 0} = {x#[] |x. x \<in> A}"
  proof
    show "{[x] |x. x \<in> A} \<subseteq> {xs. set xs \<subseteq> A \<and> length xs = Suc 0}" by auto
  next
    show "{xs. set xs \<subseteq> A \<and> length xs = Suc 0} \<subseteq> {[x] |x. x \<in> A}"
    proof
      fix xs
      assume "xs \<in> {xs. set xs \<subseteq> A \<and> length xs = Suc 0}"
      from this have "set xs \<subseteq> A \<and> length xs = Suc 0" by simp
      from this have "\<exists>x. xs = [x] \<and> x \<in> A"
        by (metis Suc_length_conv insert_subset length_0_conv list.set(2))
      from this show "xs \<in> {[x] |x. x \<in> A}" by simp
    qed
  qed
  then show ?case by simp
next
  case (Suc n)
  from this show ?case by (auto simp only: lists_length_eq_Suc_eq_image_Cons)
qed

lemma lists_length_eq_eq_empty_iff:
  "{xs. set xs \<subseteq> A \<and> length xs = n} = {} \<longleftrightarrow> (A = {} \<and> n > 0)"
proof (cases n)
  case 0
  then show ?thesis by auto
next
  case (Suc n)
  then show ?thesis by (auto simp only: lists_length_eq_Suc_eq_empty_iff)
qed

lemma finite_lists_length_eq_iff:
  "finite {xs. set xs \<subseteq> A \<and> length xs = n} \<longleftrightarrow> (finite A \<or> n = 0)"
proof
  assume "finite {xs. set xs \<subseteq> A \<and> length xs = n}"
  from this show "finite A \<or> n = 0"
  proof (induct n)
    case 0
    then show ?case by simp
  next
    case (Suc n)
    have "inj (\<lambda>(x, xs). x#xs)"
      by (auto intro: inj_onI)
    from this Suc(2) have "finite (A \<times> {xs. set xs \<subseteq> A \<and> length xs = n})"
      using finite_imageD inj_on_subset subset_UNIV lists_length_eq_Suc_eq_image_Cons[of A n]
      by fastforce
    from this have "finite A"
      by (cases "A = {}")
        (auto simp only: lists_length_eq_eq_empty_iff dest: finite_cartesian_productD1)
    from this show ?case by auto
  qed
next
  assume "finite A \<or> n = 0"
  from this show "finite {xs. set xs \<subseteq> A \<and> length xs = n}"
    by (auto intro: finite_lists_length_eq)
qed

lemma card_lists_length_eq:
  shows "card {xs. set xs \<subseteq> B \<and> length xs = n} = card B ^ n"
proof cases
  assume "finite B"
  then show ?thesis by (rule card_lists_length_eq)
next
  assume "infinite B"
  then show ?thesis
  proof cases
    assume "n = 0"
    from this have "{xs. set xs \<subseteq> B \<and> length xs = n} = {[]}" by auto
    from this \<open>n = 0\<close> show ?thesis by simp
  next
    assume "n \<noteq> 0"
    from this \<open>infinite B\<close> have "infinite {xs. set xs \<subseteq> B \<and> length xs = n}"
      by (simp add: finite_lists_length_eq_iff)
    from this \<open>infinite B\<close> show ?thesis by auto
  qed
qed

subsection \<open>Additions to Disjoint Set Theory\<close>

lemma bij_betw_congI:
  assumes "bij_betw f A A'"
  assumes "\<forall>a \<in> A. f a = g a"
  shows "bij_betw g A A'"
using assms bij_betw_cong by fastforce

lemma disjoint_family_onI[intro]:
  assumes "\<And>m n. m \<in> S \<Longrightarrow> n \<in> S \<Longrightarrow> m \<noteq> n \<Longrightarrow> A m \<inter> A n = {}"
  shows "disjoint_family_on A S"
using assms unfolding disjoint_family_on_def by simp

text \<open>
The following lemma is not needed for this development, but is useful
and could be moved to Disjoint Set theory or Equiv Relation theory if
translated from set partitions to equivalence relations.
\<close>

lemma infinite_partition_on:
  assumes "infinite A"
  shows "infinite {P. partition_on A P}"
proof -
  from \<open>infinite A\<close> obtain x where "x \<in> A"
    by (meson finite.intros(1) finite_subset subsetI)
  from \<open>infinite A\<close> have "infinite (A - {x})"
    by (simp add: infinite_remove)
  define singletons_except_one
    where "singletons_except_one = (\<lambda>a'. (\<lambda>a. if a = a' then {a, x} else {a}) ` (A - {x}))"
  have "infinite (singletons_except_one ` (A - {x}))"
  proof -
    have "inj_on singletons_except_one (A - {x})"
      unfolding singletons_except_one_def by (rule inj_onI) auto
    from \<open>infinite (A - {x})\<close> this show ?thesis
      using finite_imageD by blast
  qed
  moreover have "singletons_except_one ` (A - {x}) \<subseteq> {P. partition_on A P}"
  proof
    fix P
    assume "P \<in> singletons_except_one ` (A - {x})"
    from this obtain a' where "a' \<in> A - {x}" and P: "P = singletons_except_one a'" by blast
    have "partition_on A ((\<lambda>a. if a = a' then {a, x} else {a}) ` (A - {x}))"
      using \<open>x \<in> A\<close> \<open>a' \<in> A - {x}\<close> by (auto intro: partition_onI)
    from this have "partition_on A P"
      unfolding P singletons_except_one_def .
    from this show "P \<in> {P. partition_on A P}" ..
  qed
  ultimately show ?thesis by (simp add: infinite_super)
qed

lemma finitely_many_partition_on_iff:
  "finite {P. partition_on A P} \<longleftrightarrow> finite A"
using finitely_many_partition_on infinite_partition_on by blast

subsection \<open>Additions to Multiset Theory\<close>

lemma mset_set_subseteq_mset_set:
  assumes "finite B" "A \<subseteq> B"
  shows "mset_set A \<subseteq># mset_set B"
proof -
  from \<open>A \<subseteq> B\<close> \<open>finite B\<close> have "finite A" using finite_subset by blast
  {
    fix x
    have "count (mset_set A) x \<le> count (mset_set B) x"
      using \<open>finite A\<close> \<open>finite B\<close> \<open>A \<subseteq> B\<close>
      by (metis count_mset_set(1, 3) eq_iff subsetCE zero_le_one)
  }
  from this show "mset_set A \<subseteq># mset_set B"
    using mset_subset_eqI by blast
qed

lemma mset_set_set_mset:
  assumes "M \<subseteq># mset_set A"
  shows "mset_set (set_mset M) = M"
proof -
  {
    fix x
    from \<open>M \<subseteq># mset_set A\<close> have "count M x \<le> count (mset_set A) x"
      by (simp add: mset_subset_eq_count)
    from this have "count (mset_set (set_mset M)) x = count M x"
      by (metis count_eq_zero_iff count_greater_eq_one_iff count_mset_set
        dual_order.antisym dual_order.trans finite_set_mset)
  }
  from this show ?thesis by (simp add: multiset_eq_iff)
qed

lemma mset_set_set_mset':
  assumes "\<forall>x. count M x \<le> 1"
  shows "mset_set (set_mset M) = M"
proof -
  {
    fix x
    from assms have "count M x = 0 \<or> count M x = 1" by (auto elim: le_SucE)
    from this have "count (mset_set (set_mset M)) x = count M x"
      by (metis count_eq_zero_iff count_mset_set(1,3) finite_set_mset)
  }
  from this show ?thesis by (simp add: multiset_eq_iff)
qed

lemma card_set_mset:
  assumes "M \<subseteq># mset_set A"
  shows "card (set_mset M) = size M"
using assms
by (metis mset_set_set_mset size_mset_set)

lemma card_set_mset':
  assumes "\<forall>x. count M x \<le> 1"
  shows "card (set_mset M) = size M"
using assms
by (metis mset_set_set_mset' size_mset_set)

lemma count_mset_set_leq:
  assumes "finite A"
  shows "count (mset_set A) x \<le> 1"
using assms by (metis count_mset_set(1,3) eq_iff zero_le_one)

lemma count_mset_set_leq':
  assumes "finite A"
  shows "count (mset_set A) x \<le> Suc 0"
using assms count_mset_set_leq by fastforce

lemma msubset_mset_set_iff:
  assumes "finite A"
  shows "set_mset M \<subseteq> A \<and> (\<forall>x. count M x \<le> 1) \<longleftrightarrow> (M \<subseteq># mset_set A)"
proof
  assume "set_mset M \<subseteq> A \<and> (\<forall>x. count M x \<le> 1)"
  from this assms show "M \<subseteq># mset_set A"
    by (metis count_inI count_mset_set(1) le0 mset_subset_eqI subsetCE)
next
  assume "M \<subseteq># mset_set A"
  from this assms have "set_mset M \<subseteq> A"
    using mset_subset_eqD by fastforce
  moreover {
    fix x
    from \<open>M \<subseteq># mset_set A\<close> have "count M x \<le> count (mset_set A) x"
      by (simp add: mset_subset_eq_count)
    from this \<open>finite A\<close> have "count M x \<le> 1"
      by (meson count_mset_set_leq le_trans)
  }
  ultimately show "set_mset M \<subseteq> A \<and> (\<forall>x. count M x \<le> 1)" by simp
qed

lemma image_mset_fun_upd:
  assumes "x \<notin># M"
  shows "image_mset (f(x := y)) M = image_mset f M"
using assms by (induct M) auto

subsection \<open>Additions to Number Partitions Theory\<close>

lemma Partition_diag:
  shows "Partition n n = 1"
by (cases n) (auto simp only: Partition_diag Partition.simps(1))

subsection \<open>Cardinality Theorems with Iverson Function\<close>

definition iverson :: "bool \<Rightarrow> nat"
where
  "iverson b = (if b then 1 else 0)"

lemma card_partition_on_size1_eq_iverson:
  assumes "finite A"
  shows "card {P. partition_on A P \<and> card P \<le> k \<and> (\<forall>X\<in>P. card X = 1)} = iverson (card A \<le> k)"
proof (cases "card A \<le> k")
  case True
  from this \<open>finite A\<close> show ?thesis
    unfolding iverson_def
    using card_partition_on_size1_eq_1 by fastforce
next
  case False
  from this \<open>finite A\<close> show ?thesis
    unfolding iverson_def
    using card_partition_on_size1_eq_0 by fastforce
qed

lemma card_number_partitions_with_only_parts_1:
  "card {N. (\<forall>n. n\<in># N \<longrightarrow> n = 1) \<and> number_partition n N \<and> size N \<le> x} = iverson (n \<le> x)"
proof -
  show ?thesis
  proof cases
    assume "n \<le> x"
    from this show ?thesis
      using card_number_partitions_with_only_parts_1_eq_1
      unfolding iverson_def by auto
  next
    assume "\<not> n \<le> x"
    from this show ?thesis
      using card_number_partitions_with_only_parts_1_eq_0
      unfolding iverson_def by auto
  qed
qed

end


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

theory Axioms_Complement_Quantum
  imports Laws_Quantum Finite_Tensor_Product Quantum_Extra
begin

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

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

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

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

lemma register_decomposition:
  fixes \<Phi> :: \<open>'a::finite update \<Rightarrow> 'b::finite update\<close>
  assumes [simp]: \<open>register \<Phi>\<close>
  shows \<open>\<exists>U :: ('a \<times> ('a, 'b) complement_domain) ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b ell2. unitary U \<and>
              (\<forall>\<theta>. \<Phi> \<theta> = sandwich U (\<theta> \<otimes>\<^sub>o id_cblinfun))\<close>
  \<comment> \<open>Proof based on @{cite 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, opaque_lifting) Misc.sandwich_def T \<gamma> \<open>\<gamma> = 1\<close> adj_cblinfun_compose butterfly_adjoint cblinfun_comp_butterfly scaleC_one tensor_butterfly)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end