(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(* A theory of guarded monadic bisimulation. *)

theory Bisim_UL
imports
  "Monad_WP/NonDetMonadVCG"
  Corres_UL
  EmptyFailLib
begin

(* This still looks a bit wrong to me, although it is more or less what I want \<emdash> we want to be
   able to move hoare triples across bisimulations, and this allows guards to be left behind, more or less
definition
  "bisim_underlying SR R P P' m m' \<equiv>
    \<forall>s s'. SR s s' \<longrightarrow> (P s \<longrightarrow> (\<forall>(r, t) \<in> fst (m s). \<exists>(r', t') \<in> fst (m' s'). R r r' \<and> SR t t')) \<and>
                       (P' s' \<longrightarrow> (\<forall>(r', t') \<in> fst (m' s'). \<exists>(r, t) \<in> fst (m s). R r r' \<and> SR t t'))"
*)

definition
  bisim_underlying :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('c \<Rightarrow> 'd \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> (('c \<times> 'a) set) \<times> bool) \<Rightarrow> ('b \<Rightarrow> (('d \<times> 'b) set) \<times> bool) \<Rightarrow> bool"
where
  "bisim_underlying SR R P P' m m' \<equiv>
    \<forall>s s'. SR s  s' \<and> P s \<and> P' s' \<longrightarrow> ((\<forall>(r, t) \<in> fst (m s). \<exists>(r', t') \<in> fst (m' s'). R r r' \<and> SR t t') \<and>
                                      (\<forall>(r', t') \<in> fst (m' s'). \<exists>(r, t) \<in> fst (m s). R r r' \<and> SR t t'))"

(*
lemma bisim_is_corres_both_ways:
  "bisim_underlying SR R P P' m m' = (corres_underlying SR False R P P' m m' \<and> corres_underlying (converse SR) False (swp R) P' P m' m)"
  unfolding bisim_underlying_def corres_underlying_def
  by (fastforce simp: swp_def Ball_def Bex_def)
*)

lemma bisim_valid:
  assumes ac: "bisim_underlying (op =)  (op =) P P' a a'"
  and     rl: "\<lbrace>Q\<rbrace> a \<lbrace>S\<rbrace>"
  shows   "\<lbrace>P and P' and Q\<rbrace> a' \<lbrace>S\<rbrace>"
  using ac rl
  unfolding bisim_underlying_def valid_def
  by (fastforce simp: split_def)

lemma bisim_valid2:
  assumes ac: "bisim_underlying (op =) (op =) P P' a a'"
  and     rl: "\<lbrace>Q\<rbrace> a' \<lbrace>S\<rbrace>"
  shows   "\<lbrace>P and P' and Q\<rbrace> a \<lbrace>S\<rbrace>"
  using ac rl
  unfolding bisim_underlying_def valid_def
  by (fastforce simp: split_def)

lemma bisim_underlyingI [consumes 0, case_names Left Right]:
  assumes r1: "\<And>s s' r t. \<lbrakk>SR s s'; P s; P' s'; (r, t) \<in> fst (m s) \<rbrakk> \<Longrightarrow> \<exists>(r', t') \<in> fst (m' s'). R r r' \<and> SR t t'"
  and     r2: "\<And>s s' r' t'. \<lbrakk>SR s s'; P s; P' s'; (r', t') \<in> fst (m' s') \<rbrakk> \<Longrightarrow> \<exists>(r, t) \<in> fst (m s). R r r' \<and> SR t t'"
  shows   "bisim_underlying SR R P P' m m'"
  unfolding bisim_underlying_def
  by (fastforce dest: r1 r2 simp: split_def)

lemma bisim_underlyingE1:
  assumes bs: "bisim_underlying SR R P P' m m'"
  and     sr: "SR s s'"
  and     ps: "P s" "P' s'"
  and     ms: "(r, t) \<in> fst (m s)"
  and     rl: "\<And>r' t'. \<lbrakk> (r', t') \<in> fst (m' s'); R r r'; SR t t' \<rbrakk> \<Longrightarrow> X"
  shows X
  using bs sr ps ms unfolding bisim_underlying_def
  by (fastforce intro: rl)

lemma bisim_underlyingE2:
  assumes bs: "bisim_underlying SR R P P' m m'"
  and     sr: "SR s s'"
  and     ps: "P s" "P' s'"
  and     ms: "(r', t') \<in> fst (m' s')"
  and     rl: "\<And>r t. \<lbrakk> (r, t) \<in> fst (m s); R r r'; SR t t' \<rbrakk> \<Longrightarrow> X"
  shows X
  using bs sr ps ms unfolding bisim_underlying_def
  by (fastforce intro: rl)

lemma bisim_split:
  assumes ac: "bisim_underlying SR R' P P' a c"
  and     bd: "\<And>r r'. R' r r' \<Longrightarrow> bisim_underlying SR R (Q r) (Q' r') (b r) (d r')"
  and     v1: "\<lbrace>S\<rbrace> a \<lbrace>Q\<rbrace>"
  and     v2: "\<lbrace>S'\<rbrace> c \<lbrace>Q'\<rbrace>"
  shows "bisim_underlying SR R (P and S) (P' and S') (a >>= b) (c >>= d)"
  using ac
  apply -
  apply (rule bisim_underlyingI)
   apply (clarsimp simp: in_monad split_def)
   apply (erule (4) bisim_underlyingE1)
   apply (frule (1) use_valid [OF _ v1])
   apply (frule (1) use_valid [OF _ v2])
   apply (erule (4) bisim_underlyingE1 [OF bd])
   apply (rename_tac r'' t'')
   apply (rule_tac x = "(r'', t'')" in bexI)
    apply clarsimp
   apply (fastforce simp: in_monad)
  apply (clarsimp simp: in_monad split_def)
  apply (erule (4) bisim_underlyingE2)
  apply (frule (1) use_valid [OF _ v1])
  apply (frule (1) use_valid [OF _ v2])
  apply (erule (4) bisim_underlyingE2 [OF bd])
  apply (rename_tac r'' t'')
   apply (rule_tac x = "(r'', t'')" in bexI)
    apply clarsimp
   apply (fastforce simp: in_monad)
  done

abbreviation
  "bisim \<equiv> bisim_underlying (op =)"

lemma bisim_refl:
  assumes rrefl: "\<And>r. R r r"
  shows "bisim R P P' m m"
  apply (rule bisim_underlyingI)
   apply (clarsimp simp: split_def)
   apply (erule bexI [rotated])
   apply (simp add: rrefl)
  apply (clarsimp simp: split_def)
  apply (erule bexI [rotated])
  apply (simp add: rrefl)
  done

lemma bisim_guard_imp:
  assumes bs: "bisim_underlying SR R Q Q' m m'"
  and   rls: "\<And>s. P s \<Longrightarrow> Q s" "\<And>s. P' s \<Longrightarrow> Q' s"
  shows "bisim_underlying SR R P P' m m'"
  using bs rls
  by (fastforce intro!: bisim_underlyingI elim: bisim_underlyingE1  bisim_underlyingE2)

lemma bisim_return':
  assumes Rxx: "R x x'"
  shows "bisim_underlying SR R P P' (return x) (return x')"
  apply (rule bisim_underlyingI)
  apply (clarsimp simp: in_monad split_def Bex_def Rxx)
  apply (clarsimp simp: in_monad split_def Bex_def Rxx)
  done

lemmas bisim_return = bisim_return' [where P = \<top> and P' = \<top>]

lemma bisim_split_handle:
  assumes bm: "bisim (f' \<oplus> r) Pn Pn' m m'"
  and     bc: "\<And>x x'. f' x x' \<Longrightarrow> bisim (f \<oplus> r) (Pf x) (Pf' x') (c x) (c' x')"
  and     v1: "\<lbrace>P\<rbrace> m \<lbrace>\<lambda>_ _. True\<rbrace>, \<lbrace>Pf\<rbrace>"
  and     v2: "\<lbrace>P'\<rbrace> m' \<lbrace>\<lambda>_ _. True\<rbrace>, \<lbrace>Pf'\<rbrace>"
  shows "bisim (f \<oplus> r) (Pn and P) (Pn' and P') (m <handle> c) (m' <handle> c')"
  unfolding handleE_def handleE'_def
  apply (rule bisim_split [where Q = "\<lambda>r s. case_sum (\<lambda>l. Pf l s) (\<lambda>_. True) r" and Q' = "\<lambda>r s. case_sum (\<lambda>l. Pf' l s) (\<lambda>_. True) r", OF bm, folded validE_def])
  apply (case_tac ra)
   apply clarsimp
   apply (erule bc)
  apply clarsimp
  apply (rule bisim_return')
  apply simp
  apply (rule v1)
  apply (rule v2)
  done

(* Set up wpc *)
lemma wpc_helper_bisim:
  "bisim_underlying SR r Q Q' f f' \<Longrightarrow> wpc_helper (P, P') (Q, {s. Q' s}) (bisim_underlying SR r P (\<lambda>s. s \<in> P') f f')"
  apply (clarsimp simp: wpc_helper_def)
  apply (erule bisim_guard_imp)
   apply simp
  apply fastforce
  done

wpc_setup "\<lambda>m. bisim_underlying SR r P P' a m" wpc_helper_bisim
wpc_setup "\<lambda>m. bisim_underlying SR r P P' a (m >>= c)" wpc_helper_bisim

lemma bisim_split_refl:
  assumes bs: "\<And>r. bisim R (Q r) (Q' r) (b r) (d r)"
  and    v1: "\<lbrace>S\<rbrace> a \<lbrace>Q\<rbrace>"
  and   v2: "\<lbrace>S'\<rbrace> a \<lbrace>Q'\<rbrace>"
  shows "bisim R S S' (a >>= b) (a >>= d)"
  apply (rule bisim_guard_imp)
  apply (rule bisim_split [OF _ _ v1 v2])
   apply (rule bisim_refl [where P = \<top> and P' = \<top> and R = "op =", OF refl])
  apply simp
  apply (rule bs)
  apply simp_all
  done

lemma bisim_throwError':
  "f e e' \<Longrightarrow> bisim_underlying SR (f \<oplus> R') P P' (throwError e) (throwError e')"
  apply (rule bisim_underlyingI)
  apply (clarsimp simp: in_monad Bex_def)+
  done

lemmas bisim_throwError = bisim_throwError' [where P = \<top> and P' = \<top>]

lemma bisim_splitE:
  assumes ac: "bisim_underlying SR (f \<oplus> R') P P' a c"
  and     bd: "\<And>r r'. R' r r' \<Longrightarrow> bisim_underlying SR (f \<oplus> R) (Q r) (Q' r') (b r) (d r')"
  and     v1: "\<lbrace>S\<rbrace> a \<lbrace>Q\<rbrace>, -"
  and     v2: "\<lbrace>S'\<rbrace> c \<lbrace>Q'\<rbrace>, -"
  shows "bisim_underlying SR (f \<oplus> R) (P and S) (P' and S') (a >>=E b) (c >>=E d)"
  apply (simp add: bindE_def lift_def[abs_def])
  apply (rule bisim_split [where Q = "\<lambda>r s. case_sum  (\<lambda>_. True) (\<lambda>l. Q l s) r" and Q' = "\<lambda>r s. case_sum  (\<lambda>_. True) (\<lambda>l. Q' l s) r", OF ac, folded validE_def, folded validE_R_def])
  apply (case_tac r')
   apply clarsimp
   apply (erule bisim_throwError')
  apply clarsimp
  apply (erule bd)
  apply (rule v1)
  apply (rule v2)
  done

lemma bisim_split_reflE:
  assumes ab: "\<And>r. bisim (f \<oplus> R) (Q r) (Q' r) (a r) (b r)"
  and     v1: "\<lbrace>S\<rbrace> m \<lbrace>Q\<rbrace>, -"
  and     v2: "\<lbrace>S'\<rbrace> m \<lbrace>Q'\<rbrace>, -"
  and  refls: "\<And>e. f e e" "\<And>r. R r r"
  shows "bisim (f \<oplus> R) S S' (m >>=E a) (m >>=E b)"
  using refls
  apply -
  apply (rule bisim_guard_imp)
  apply (rule bisim_splitE [where R' = "op =", OF _ _ v1 v2])
  apply (rule bisim_refl)
  apply (case_tac r, simp_all)[1]
  apply simp
  apply (rule ab)
  apply simp+
  done

lemma bisim_split_bind_case_sum:
  "\<lbrakk>bisim_underlying sr (lr \<oplus> rr) P P' a d;
   \<And>rv rv'. lr rv rv' \<Longrightarrow> bisim_underlying sr r (R rv) (R' rv') (b rv) (e rv');
   \<And>rv rv'. rr rv rv' \<Longrightarrow> bisim_underlying sr r (S rv) (S' rv') (c rv) (f rv'); \<lbrace>Q\<rbrace> a \<lbrace>S\<rbrace>, \<lbrace>R\<rbrace>; \<lbrace>Q'\<rbrace> d \<lbrace>S'\<rbrace>, \<lbrace>R'\<rbrace>\<rbrakk>
  \<Longrightarrow> bisim_underlying sr r (P and Q) (P' and Q') (a >>= case_sum b c) (d >>= case_sum e f)"
  apply (erule bisim_split [where Q = "\<lambda>rv s. case_sum (\<lambda>l. R l s) (\<lambda>r. S r s) rv" and Q' = "\<lambda>rv s. case_sum (\<lambda>l. R' l s) (\<lambda>r. S' r s) rv", folded validE_def])
   apply (case_tac r')
    apply clarsimp
   apply clarsimp
  apply assumption+
  done

lemma bisim_liftE [simp]:
  "bisim_underlying SR (f \<oplus> R) P P' (liftE a) (liftE b) = bisim_underlying SR R P P' a b"
  by (fastforce simp: in_monad intro: bisim_underlyingI elim: bisim_underlyingE1  bisim_underlyingE2)

lemma bisim_when:
  assumes bs:  "b \<Longrightarrow> bisim_underlying SR R P P' m m'"
  and     rr: "R () ()"
  shows   "bisim_underlying SR R (\<lambda>s. b \<longrightarrow> P s) (\<lambda>s. b \<longrightarrow> P' s) (when b m) (when b m')"
  using assms
  apply (cases b, simp_all add: when_def)
  apply (erule bisim_return)
  done

(* not really used *)
definition
  "det_on P f \<equiv> \<forall>s. P s \<longrightarrow> (\<exists>r. f s = ({r}, False))"

lemma det_onE:
  "\<lbrakk>det_on P f; P s; \<And>r s'. \<lbrakk> (r, s') \<in> fst (f s); \<not> snd (f s)\<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  unfolding det_on_def by fastforce

lemma bisim_noop_det_on:
  assumes a: "\<And>s. \<lbrace>Pa and op = s\<rbrace> a \<lbrace>\<lambda>_. op = s\<rbrace>"
  and     b: "\<And>s. \<lbrace>Pb and op = s\<rbrace> b \<lbrace>\<lambda>_. op = s\<rbrace>"
  and    da: "det_on P a"
  and    db: "det_on P' b"
  shows   "bisim_underlying sr dc (Pa and P) (Pb and P') a b"
  using da db
  apply -
  apply (rule bisim_underlyingI)
  apply clarsimp
  apply (erule (1) det_onE)+
  apply (frule use_valid [OF _ a], fastforce)
  apply (frule use_valid [OF _ b], fastforce)
  apply fastforce

  apply clarsimp
  apply (erule (1) det_onE)+
  apply (frule use_valid [OF _ a], fastforce)
  apply (frule use_valid [OF _ b], fastforce)
  apply fastforce
  done

lemma det_on_gets:
  "det_on \<top> (gets f)" unfolding det_on_def
  by (clarsimp simp: gets_def return_def bind_def get_def)

lemma hoare_gen_asmE':
  "(P \<Longrightarrow> \<lbrace>P'\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>R\<rbrace>) \<Longrightarrow> \<lbrace>P' and K P\<rbrace> f \<lbrace>Q\<rbrace>, \<lbrace>R\<rbrace>"
  unfolding validE_def
  by (erule hoare_gen_asm)

lemma det_onE':
  "\<lbrakk>det_on P f; P s; \<And>r s'. \<lbrakk> f s = ({(r, s')}, False)\<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  unfolding det_on_def by fastforce

(* ugh *)
lemma det_on_guard_imp [wp_comb]:
  assumes da: "det_on P' a"
  and   "\<And>s. P s \<Longrightarrow> P' s"
  shows "det_on P a"
  using assms unfolding det_on_def by auto

lemma det_on_split [wp_split]:
  assumes da: "det_on Pa a"
  and     db: "\<And>x. det_on (Pb x) (b x)"
  and      v: "\<lbrace>Pb'\<rbrace> a \<lbrace>Pb\<rbrace>"
  shows "det_on (Pa and Pb') (a >>= b)"
  unfolding det_on_def using da
  apply -
  apply clarsimp
  apply (erule (1) det_onE)
  apply (frule (1) use_valid [OF _ v])
  apply (erule det_onE' [OF da])
  apply (erule det_onE' [OF db])
  apply (clarsimp simp: bind_def split_def)
  done

lemma det_det_on:
  "det m \<Longrightarrow> det_on \<top> m"
  unfolding det_def det_on_def by auto

lemma det_on_liftE [wp]:
  "det_on P m \<Longrightarrow> det_on P (liftE m)"
  unfolding liftE_def
  apply (rule det_on_guard_imp)
  apply (erule det_on_split [OF _ det_det_on])
   apply simp
  apply wp
  apply simp
  done

lemma det_on_lift [wp]:
  "(\<And>y. det_on (P y) (m y)) \<Longrightarrow> det_on (case_sum (\<lambda>_. \<top>) P x) (lift m x)"
  unfolding lift_def
  by (auto simp: det_on_def throwError_def return_def split: sum.splits)

lemma det_on_assert_opt [wp]:
  "det_on (\<lambda>_. x \<noteq> None) (assert_opt x)"
  unfolding det_on_def assert_opt_def by (fastforce split: option.splits simp: fail_def return_def)

lemmas dets_to_det_on [wp] = det_det_on [OF det_gets] det_det_on [OF return_det]

(* Set up wpc *)
lemma wpc_helper_det_on:
  "det_on Q f \<Longrightarrow> wpc_helper (P, P') (Q, Q') (det_on P f)"
  apply (clarsimp simp: wpc_helper_def det_on_def)
  done

wpc_setup "\<lambda>m. det_on P m" wpc_helper_det_on
wpc_setup "\<lambda>m. det_on P (m >>= c)" wpc_helper_det_on

lemma bisim_symb_exec_r_det_on:
  assumes z: "\<And>rv. bisim_underlying sr r P (Q' rv) x (y rv)"
  assumes y: "\<lbrace>P'\<rbrace> m \<lbrace>Q'\<rbrace>"
  assumes x: "\<And>s. \<lbrace>Pe and op = s\<rbrace> m \<lbrace>\<lambda>r. op = s\<rbrace>"
  assumes nf: "det_on Pd m"
  shows      "bisim_underlying sr r P (P' and Pe and Pd) x (m >>= (\<lambda>rv. y rv))"
  apply (rule bisim_guard_imp)
    apply (subst gets_bind_ign [symmetric], rule bisim_split)
      apply (rule bisim_noop_det_on [OF _ x det_on_gets])
      apply wp
      apply fastforce
     apply (rule nf)
    apply (rule z)
   apply (wp y)+
  apply simp+
  done

definition
  not_empty :: "('a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b set \<times> bool) \<Rightarrow> bool"
where
  "not_empty P f \<equiv> \<forall>s. P s \<longrightarrow> (fst (f s) \<noteq> {})"

lemma not_emptyE:
  "\<lbrakk> not_empty P f; P s; \<And>r s'. \<lbrakk> (r, s') \<in> fst (f s)\<rbrakk> \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  unfolding not_empty_def by fastforce

(* ugh *)
lemma not_empty_guard_imp [wp_comb]:
  assumes da: "not_empty P' a"
  and   "\<And>s. P s \<Longrightarrow> P' s"
  shows "not_empty P a"
  using assms unfolding not_empty_def by auto

lemma not_empty_split [wp_split]:
  assumes da: "not_empty Pa a"
  and     db: "\<And>x. not_empty (Pb x) (b x)"
  and      v: "\<lbrace>Pb'\<rbrace> a \<lbrace>Pb\<rbrace>"
  shows "not_empty (Pa and Pb') (a >>= b)"
  unfolding not_empty_def using da
  apply -
  apply clarsimp
  apply (erule (1) not_emptyE)
  apply (frule (1) use_valid [OF _ v])
  apply (erule not_emptyE [OF da])
  apply (erule not_emptyE [OF db])
  apply (fastforce simp: bind_def split_def)
  done

lemma not_empty_return [wp]:
  "not_empty \<top> (return x)"
  unfolding not_empty_def
  by (simp add: return_def)

lemma not_empty_liftE [wp]:
  assumes ne: "not_empty P m"
  shows "not_empty P (liftE m)"
  unfolding liftE_def
  apply (rule not_empty_guard_imp)
  apply (wp ne)
  apply simp
  done

lemma not_empty_lift [wp]:
  "(\<And>y. not_empty (P y) (m y)) \<Longrightarrow> not_empty (case_sum (\<lambda>_. \<top>) P x) (lift m x)"
  unfolding lift_def
  by (auto simp: not_empty_def throwError_def return_def split: sum.splits)

lemma not_empty_assert_opt [wp]:
  "not_empty (\<lambda>_. x \<noteq> None) (assert_opt x)"
  unfolding not_empty_def assert_opt_def by (fastforce split: option.splits simp: fail_def return_def)

lemma not_empty_gets [wp]:
  "not_empty \<top> (gets f)" unfolding not_empty_def
  by (clarsimp simp: gets_def return_def bind_def get_def)

(* Set up wpc *)
lemma wpc_helper_not_empty:
  "not_empty Q f \<Longrightarrow> wpc_helper (P, P') (Q, Q') (not_empty P f)"
  apply (clarsimp simp: wpc_helper_def not_empty_def)
  done

wpc_setup "\<lambda>m. not_empty P m" wpc_helper_not_empty
wpc_setup "\<lambda>m. not_empty P (m >>= c)" wpc_helper_not_empty

lemma bisim_noop:
  assumes a: "\<And>s. \<lbrace>Pa and op = s\<rbrace> a \<lbrace>\<lambda>_. op = s\<rbrace>"
  and     b: "\<And>s. \<lbrace>Pb and op = s\<rbrace> b \<lbrace>\<lambda>_. op = s\<rbrace>"
  and    da: "not_empty P a"
  and    db: "not_empty P' b"
  shows   "bisim_underlying sr dc (Pa and P) (Pb and P') a b"
  using da db
  apply -
  apply (rule bisim_underlyingI)
  apply clarsimp
  apply (erule (1) not_emptyE)+
  apply (frule use_valid [OF _ a], fastforce)
  apply (frule use_valid [OF _ b], fastforce)
  apply fastforce

  apply clarsimp
  apply (erule (1) not_emptyE)+
  apply (frule use_valid [OF _ a], fastforce)
  apply (frule use_valid [OF _ b], fastforce)
  apply fastforce
  done

lemma bisim_symb_exec_r:
  assumes  z: "\<And>rv. bisim_underlying sr r P (Q' rv) x (y rv)"
  assumes  y: "\<lbrace>P'\<rbrace> m \<lbrace>Q'\<rbrace>"
  assumes  x: "\<And>s. \<lbrace>Pe and op = s\<rbrace> m \<lbrace>\<lambda>r. op = s\<rbrace>"
  assumes ne: "not_empty Pd m"
  shows      "bisim_underlying sr r P (P' and Pe and Pd) x (m >>= (\<lambda>rv. y rv))"
  apply (rule bisim_guard_imp)
    apply (subst gets_bind_ign [symmetric], rule bisim_split)
      apply (rule bisim_noop [OF _ x not_empty_gets])
      apply wp
      apply fastforce
     apply (rule ne)
    apply (rule z)
   apply (wp y)+
  apply simp+
  done

lemma bisim_not_empty:
  assumes bs: "bisim r P P' m m'"
  and     ne: "not_empty R m"
  shows   "not_empty (P and P' and R) m'"
  unfolding not_empty_def using bs ne
  apply clarsimp
  apply (erule (1) not_emptyE)
  apply (erule_tac s=s and s'=s in bisim_underlyingE1 [where SR = "op ="])
      apply simp+
  done

lemma bisim_split_req:
  assumes ac: "bisim (op =) P P' a c"
  and     bd: "\<And>r. bisim R (Q r) (Q' r) (b r) (d r)"
  and     v1: "\<lbrace>S\<rbrace> a \<lbrace>\<lambda>r. Q r and Q' r\<rbrace>"
  shows "bisim R (P and S) P' (a >>= b) (c >>= d)"
  using ac
  apply -
  apply (rule bisim_underlyingI)
   apply (clarsimp simp: in_monad split_def)
   apply (erule bisim_underlyingE1)
    apply simp
    apply assumption+
   apply (frule (1) use_valid [OF _ v1])
   apply clarsimp
   apply (rule bisim_underlyingE1 [OF bd])
    apply simp
    apply assumption+
   apply (rename_tac r'' t'')
   apply (rule_tac x = "(r'', t'')" in bexI)
    apply clarsimp
   apply (fastforce simp: in_monad)

   apply (clarsimp simp: in_monad split_def)
   apply (erule bisim_underlyingE2)
    apply simp
    apply assumption+
   apply (frule (1) use_valid [OF _ v1])
   apply clarsimp
   apply (rule bisim_underlyingE2 [OF bd])
    apply simp
    apply assumption+
   apply (rename_tac r'' t'')
   apply (rule_tac x = "(r'', t'')" in bexI)
    apply clarsimp
   apply (fastforce simp: in_monad)
  done

lemma bisim_splitE_req:
  assumes ac: "bisim (f \<oplus> op =) P P' a c"
  and     bd: "\<And>r. bisim (f \<oplus> R) (Q r) (Q' r) (b r) (d r)"
  and     v1: "\<lbrace>S\<rbrace> a \<lbrace>\<lambda>r. Q r and Q' r\<rbrace>, -"
  shows "bisim (f \<oplus> R) (P and S) P' (a >>=E b) (c >>=E d)"
  using ac
  apply -
  apply (simp add: bindE_def lift_def[abs_def])
  apply (rule bisim_underlyingI)
   apply (clarsimp simp: in_monad split_def)
   apply (erule bisim_underlyingE1)
    apply simp
    apply assumption+
   apply (frule (1) use_valid [OF _ v1 [unfolded validE_R_def validE_def]])
   apply clarsimp
   apply (case_tac x)
    apply (clarsimp simp: in_monad)
    apply (rule_tac x = "(Inl y', t')" in bexI)
    apply fastforce
   apply (fastforce simp: in_monad)
   apply clarsimp
   apply (rule bisim_underlyingE1 [OF bd])
    apply simp
    apply assumption+
   apply (rename_tac r'' t'')
   apply (rule_tac x = "(r'', t'')" in bexI)
    apply clarsimp
   apply (fastforce simp: in_monad)

   apply (clarsimp simp: in_monad split_def)
   apply (erule bisim_underlyingE2)
    apply simp
    apply assumption+
   apply (frule (1) use_valid [OF _ v1 [unfolded validE_R_def validE_def]])
   apply clarsimp
   apply (case_tac r)
    apply (clarsimp simp: in_monad)
    apply (rule_tac x = "(Inl aa, s'')" in bexI)
    apply fastforce
   apply (fastforce simp: in_monad)
   apply clarsimp
   apply (rule bisim_underlyingE2 [OF bd])
    apply simp
    apply assumption+
   apply (rename_tac r'' t'')
   apply (rule_tac x = "(r'', t'')" in bexI)
    apply clarsimp
   apply (fastforce simp: in_monad)
  done

lemma bisim_symb_exec_r_bs:
  assumes bs: "bisim op = R R' (return ()) m"
  and      z: "\<And>rv. bisim r P P' x (y rv)"
  shows      "bisim r (P and R and P') R' x (m >>= (\<lambda>rv. y rv))"
  apply (rule bisim_guard_imp)
    apply (subst return_bind [symmetric, where f = "\<lambda>(_ :: unit).x"],  rule bisim_split_req)
    apply (rule bs)
     apply (rule z)
     apply wp
   apply simp
  apply simp+
  done

end


theory OldLValue
  imports Main "HOL-Library.Rewrite" (* "HOL-Cardinals.Cardinals" *)
    (* "Jordan_Normal_Form.Matrix_Impl" *) Complex_Main
    (* "HOL-Library.Indicator_Function" *)
begin

(* no_syntax "\<^const>Group.m_inv" :: "('a, 'b) monoid_scheme => 'a => 'a" ("inv\<index> _" [81] 80) *)

typedef 'a index = "UNIV::'a set" ..
typedef 'a factor = "UNIV::'a set" ..
typedef 'a target = "UNIV::'a set" ..

inductive_set dependent_functions' :: "'b \<Rightarrow> 'a set \<Rightarrow> ('a\<Rightarrow>'b set) \<Rightarrow> ('a\<Rightarrow>'b) set"
  for undef :: 'b and domain :: "'a set" and range :: "'a \<Rightarrow> 'b set" where
  "\<lbrakk> \<And>a. a\<notin>domain \<Longrightarrow> f a = undef;
     \<And>a. a\<in>domain \<Longrightarrow> f a \<in> range a \<rbrakk>
   \<Longrightarrow> f \<in> dependent_functions' undef domain range"

abbreviation "dependent_functions == dependent_functions' undefined"

definition "restrict f S x = (if x\<in>S then f x else undefined)"

lemma restrict_image: "restrict f X ` X = f ` X"
  apply (rule image_cong, simp)
  unfolding restrict_def by simp

lemma inj_on_restrict: "inj_on (restrict f X) X = inj_on f X"
proof
  assume inj: "inj_on (restrict f X) X"
  show "inj_on f X"
    apply (rule inj_onI)
    apply (rule inj[THEN inj_onD])
    unfolding restrict_def by auto
next
  assume inj: "inj_on f X"
  show "inj_on (restrict f X) X"
    apply (rule inj_onI)
    apply (rule inj[THEN inj_onD])
    unfolding restrict_def by auto
qed

lemma dependent_functions_restrict:
  assumes "f \<in> dependent_functions D R"
  assumes D': "D' \<subseteq> D"
  shows "restrict f D' \<in> dependent_functions D' R"
  apply (rule dependent_functions'.intros)
  unfolding restrict_def apply auto
  by (meson assms contra_subsetD dependent_functions'.cases)

lemma dependent_functions_restrict_twice[simp]:
  "restrict (restrict f D) D'
      = restrict f (D\<inter>D')"
  unfolding restrict_def by auto

lemma dependent_functions_restrict_surj:
  assumes D: "D \<subseteq> D'"
  assumes A: "\<And>i. i\<in>D' \<Longrightarrow> A i \<noteq> {}"
  shows "(\<lambda>f. restrict f D) ` dependent_functions D' A = dependent_functions D A"
proof auto
  fix f assume f: "f \<in> dependent_functions D' A"
  show "restrict f D \<in> dependent_functions D A"
    unfolding restrict_def
    apply (rule dependent_functions'.intros)
    using f apply cases apply simp
    using f apply cases using D by auto
next
  fix f assume f: "f \<in> dependent_functions D A"
  define f' where "f' i = (if i\<in>D then f i else if i\<in>D' then (SOME x. x:A i) else undefined)" for i
  have "f = restrict f' D"
    unfolding restrict_def f'_def
    apply (rule ext) using f apply cases by auto
  moreover have "f' \<in> dependent_functions D' A"
    unfolding f'_def
    apply (rule dependent_functions'.intros)
    using D apply auto
    apply (meson dependent_functions'.cases f)
    by (simp add: A some_in_eq)
  ultimately show "f \<in> (\<lambda>f. restrict f D) ` dependent_functions D' A"
    by (rule image_eqI[where x=f'])
qed

lemma dependent_functions_nonempty:
  assumes "\<And>i. i\<in>I \<Longrightarrow> A i \<noteq> {}"
  shows "dependent_functions' u I A \<noteq> {}"
proof -
  from assms obtain f where f: "f i \<in> A i" if "i\<in>I" for i
    apply atomize_elim apply (rule choice) by auto
  have "(\<lambda>i. if i:I then f i else u) : dependent_functions' u I A"
    apply (rule dependent_functions'.intros)
    using f by auto
  thus ?thesis
    by auto
qed

definition "leq_card A B = (\<exists>f. inj_on f A \<and> f`A \<subseteq> B)" (* Equivalent to (card_of A \<le>o card_of B). TODO use that? *)

lemma leq_cardI: assumes "inj_on f A" and "f`A \<subseteq> B" shows "leq_card A B"
  unfolding leq_card_def using assms by auto
lemma leq_cardI_surj: assumes "f`B \<supseteq> A" shows "leq_card A B"
  unfolding leq_card_def using assms
  by (meson image_subsetI inj_on_inv_into inv_into_into rev_subsetD)
lemma leq_cardI_bij: assumes "bij_betw f A B" shows "leq_card A B"
  using assms bij_betw_imp_inj_on bij_betw_imp_surj_on leq_card_def by fastforce
lemma leq_cardI_bij': assumes "bij_betw f B A" shows "leq_card A B"
  using assms bij_betw_inv leq_cardI_bij by blast

(* lemma leq_card_fst: assumes "A2\<noteq>{}" assumes "leq_card (A1\<times>A2) B" shows "leq_card A1 B"
   *)

(* lemma leq_card_prod: assumes "B\<noteq>{}" shows "leq_card A (A\<times>B)"
   *)

lemma leq_card_prod2: assumes "A\<noteq>{}" shows "leq_card B (A\<times>B)"
proof -
  obtain a where a: "a \<in> A" using assms by auto
  show ?thesis
    unfolding leq_card_def
    apply (rule exI[of _ "%b. (a,b)"])
    by (auto simp: a inj_on_def)
qed

lemma leq_card_trans[trans]: assumes "leq_card A B" and "leq_card B C" shows "leq_card A C"
  unfolding leq_card_def proof -
  from assms obtain f1 f2 where inj_f1: "inj_on f1 A" and rg_f1: "f1 ` A \<subseteq> B"
    and inj_f2: "inj_on f2 B" and rg_f2: "f2 ` B \<subseteq> C"
    apply atomize_elim unfolding leq_card_def by auto
  from inj_f1 have "inj_on (f2 o f1) A"
    apply (rule comp_inj_on)
    using inj_f2 inj_on_subset rg_f1 by auto
  moreover
  from rg_f1 rg_f2 have "(f2 o f1) ` A \<subseteq> C"
    by fastforce
  ultimately show "\<exists>f. inj_on f A \<and> f ` A \<subseteq> C" sorry
qed
lemma leq_card_refl[intro]: "leq_card A A"
  unfolding leq_card_def by force

lemma leq_card_UNIV[simp]: "leq_card (A::'a set) (UNIV::'a set)"
  unfolding leq_card_def apply (rule exI[of _ id]) by simp

lemma bij_betw_dependent_functions:
  assumes bij_f: "\<And>i. i \<in> I \<Longrightarrow> bij_betw (f i) (A i) (B i)"
  assumes f_undef: "\<And>i x. i \<notin> I \<Longrightarrow> f i x = u2"
  shows "bij_betw (\<lambda>g i. f i (g i)) (dependent_functions' u1 I A) (dependent_functions' u2 I B)"
proof (rule bij_betwI')
  fix x y
  assume x: "x \<in> dependent_functions' u1 I A"
  show "(\<lambda>i. f i (x i)) \<in> dependent_functions' u2 I B"
    apply (rule dependent_functions'.intros)
    apply (simp add: assms(2))
    by (meson x assms(1) bij_betwE dependent_functions'.cases)
  assume y: "y \<in> dependent_functions' u1 I A"
  from bij_f have inj_f: "inj_on (f i) (A i)" if "i:I" for i
    by (simp add: bij_betw_def that)
  have "x = y" if "(\<lambda>i. f i (x i)) = (\<lambda>i. f i (y i))"
    apply (rule ext)
    using that inj_f
    by (metis (full_types) dependent_functions'.cases inj_on_eq_iff x y)
  then show "((\<lambda>i. f i (x i)) = (\<lambda>i. f i (y i))) = (x = y)"
    by auto
next
  fix y
  assume y: "y \<in> dependent_functions' u2 I B"
  have "\<exists>x'. (y i = f i x' \<and> (i\<in>I \<longrightarrow> x' \<in> A i) \<and> (i\<notin>I \<longrightarrow> x' = u1))" for i
    apply (cases "i\<in>I")
    apply (metis bij_betw_def bij_f dependent_functions'.cases image_iff y)
    using dependent_functions'.simps f_undef y by fastforce
  then obtain x where x: "(y i = f i (x i) \<and> (i\<in>I \<longrightarrow> x i \<in> A i) \<and> (i\<notin>I \<longrightarrow> x i = u1))" for i
    apply atomize_elim apply (rule choice) by simp
  then have "x\<in>dependent_functions' u1 I A"
    apply (rule_tac dependent_functions'.intros) by auto
  moreover
  from x have "y = (\<lambda>i. f i (x i))"
    by auto
  ultimately show "\<exists>x\<in>dependent_functions' u1 I A. y = (\<lambda>i. f i (x i))"
    by auto
qed

(* lemma bij_dependent_functions_split:
  assumes "bij_betw (\<lambda>x i. (f1 i (x i), f2 i (x i))) (dependent_functions' u I A) (dependent_functions' (v1,v2) I (\<lambda>i. B i \<times> C i))"
  shows "bij_betw (\<lambda>x. (\<lambda>i. f1 i (x i), \<lambda>i. f2 i (x i))) (dependent_functions' u I A) (dependent_functions' v1 I B \<times> dependent_functions' v2 I C)"
   *)

lemma dependent_functions_mono_domain:
  assumes "I \<subseteq> J"
  assumes "\<And>i. i \<in> J-I \<Longrightarrow> A i \<noteq> {}"
  shows "leq_card (dependent_functions I A) (dependent_functions J A)"
proof -
  define f where "f x i = (if i \<in> J-I then (SOME a. a : A i) else x i)" for x i
  have inj: "inj_on f (dependent_functions I A)"
  proof (rule inj_onI, rule ext)
    fix x y i
    assume xdep: "x \<in> dependent_functions I A" and ydep: "y \<in> dependent_functions I A" and feq: "f x = f y"
    show "x i = y i"
    proof (cases "i \<in> J-I")
      case True
      then have "i \<notin> I" by simp
      with xdep ydep have "x i = undefined" and "y i = undefined"
        by (simp add: dependent_functions'.simps)+
      then show "x i = y i" by simp
    next
      case False
      then have "f x i = x i" and "f y i = y i"
        unfolding f_def by auto
      with feq show "x i = y i" by simp
    qed
  qed
  have range: "f ` dependent_functions I A \<subseteq> dependent_functions J A"
  proof (rule subsetI, drule imageE, rename_tac y x)
    fix x y assume y: "y = f x" and xdep: "x \<in> dependent_functions I A"
    show "y \<in> dependent_functions J A"
    proof (unfold y, rule dependent_functions'.intros; rename_tac i)
      fix i assume "i \<notin> J"
      with xdep show "f x i = undefined"
        unfolding f_def apply auto
        by (meson assms(1) contra_subsetD dependent_functions'.cases)
    next
      fix i assume "i \<in> J"
      with xdep show "f x i \<in> A i"
        unfolding f_def apply auto
        apply (simp add: assms(2) some_in_eq)
        by (simp add: dependent_functions'.simps)
    qed
  qed
  from inj range show ?thesis
    unfolding leq_card_def by auto
qed

lemma dependent_functions_mono:
  assumes "\<And>i. i\<in>I \<Longrightarrow> leq_card (A i) (B i)"
  shows "leq_card (dependent_functions I A) (dependent_functions I B)"
proof -
  obtain f where f: "inj_on (f i) (A i) \<and> f i ` A i \<subseteq> B i" if "i\<in>I" for i
    unfolding leq_card_def apply atomize_elim unfolding Ball_def[symmetric]
    apply (rule bchoice)
    using assms[unfolded leq_card_def] by simp
  define F where "F g = (\<lambda>i. if i\<in>I then f i (g i) else undefined)" for g
  have "F g \<in> dependent_functions I B" if "g \<in> dependent_functions I A" for g
    unfolding F_def apply (rule dependent_functions'.intros) apply auto
    using that apply cases using f by blast
  then have "F ` dependent_functions I A \<subseteq> dependent_functions I B"
    by auto
  moreover
  have "F g1 = F g2 \<Longrightarrow> g1 = g2"
    if "g1 \<in> dependent_functions I A" and "g2 \<in> dependent_functions I A" for g1 g2
    using that(1) apply cases using that(2) apply cases
    unfolding F_def apply (rule ext)
    by (metis (no_types, lifting) f inj_on_contraD)
  then have "inj_on F (dependent_functions I A)"
    by (rule inj_onI)
  ultimately
  show ?thesis
    unfolding leq_card_def by auto
qed

definition "dependent_functions_split I f = ((\<lambda>i. if i\<in>I then fst (f i) else undefined),
                                             (\<lambda>i. if i\<in>I then snd (f i) else undefined))"

lemma bij_betw_dependent_functions_split:
  assumes "\<And>i. i\<in>I \<Longrightarrow> AB i = A i \<times> B i"
  shows "bij_betw (dependent_functions_split I) (dependent_functions' u I AB)
     (dependent_functions I A \<times> dependent_functions I B)"
proof (rule bij_betwI')
  fix x y :: "'a \<Rightarrow> 'b \<times> 'c"
  assume x: "x \<in> dependent_functions' u I AB"
  then have x_undef: "i \<notin> I \<Longrightarrow> x i = u" for i
    by cases
  assume y: "y \<in> dependent_functions' u I AB"
  then have y_undef: "i \<notin> I \<Longrightarrow> y i = u" for i
    by cases
  show "(dependent_functions_split I x = dependent_functions_split I y) = (x = y)"
    unfolding o_def dependent_functions_split_def
    apply auto
    by (metis prod_eq_iff x_undef y_undef ext)
  have "(\<lambda>i. if i \<in> I then fst (x i) else undefined) \<in> dependent_functions I A"
    using x apply cases apply (subst dependent_functions'.simps)
    using assms by force
  moreover
  have "(\<lambda>i. if i \<in> I then snd (x i) else undefined) \<in> dependent_functions I B"
    using x apply cases apply (subst dependent_functions'.simps)
    using assms by force
  ultimately
  show "dependent_functions_split I x \<in> dependent_functions I A \<times> dependent_functions I B"
    unfolding dependent_functions_split_def
    by simp
next
  fix g
  assume "g \<in> dependent_functions I A \<times> dependent_functions I B"
  then obtain g1 g2 where g: "g = (g1,g2)" and g1: "g1 \<in> dependent_functions I A" and g2: "g2 \<in> dependent_functions I B"
    by auto
  obtain f1 where f1: "g1 i = (if i \<in> I then f1 i else undefined)" for i
    by (metis dependent_functions'.cases g1)
  obtain f2 where f2: "g2 i = (if i \<in> I then f2 i else undefined)" for i
    by (metis dependent_functions'.cases g2)
  define f where "f i = (if i:I then (f1 i, f2 i) else u)" for i
  have fAB: "f \<in> dependent_functions' u I AB"
    apply (rule dependent_functions'.intros) unfolding f_def using assms apply auto
    apply (metis dependent_functions'.cases f1 g1)
    by (metis dependent_functions'.cases f2 g2)
  show "\<exists>f\<in>dependent_functions' u I AB. g = dependent_functions_split I f"
    unfolding g dependent_functions_split_def apply (rule bexI[of _ f])
    using f1 f2 apply (fastforce simp: f_def)
    using fAB by assumption
qed

lemma dependent_functions_split:
  assumes disjoint: "I\<inter>J={}"
  shows "bij_betw (\<lambda>f. (restrict f I, restrict f J))
      (dependent_functions (I\<union>J) A)
      (dependent_functions I A \<times> dependent_functions J A)"
proof (rule bij_betwI', auto)
  fix x y assume x: "x \<in> dependent_functions (I \<union> J) A"
    and y: "y \<in> dependent_functions (I \<union> J) A"
    and eqI: "restrict x I = restrict y I"
    and eqJ: "restrict x J = restrict y J"
  show "x = y"
  proof (rule ext)
    fix i
    consider (I) "i : I" | (J) "i : J" | (none) "i \<notin> I\<union>J" by auto
    then show "x i = y i"
    proof cases
      case I
      then show ?thesis
        using eqI unfolding restrict_def by metis
    next
      case J
      then show ?thesis
        using eqJ unfolding restrict_def by metis
    next
      case none
      show ?thesis
        using x apply cases using y apply cases
        using none by metis
    qed
  qed
next
  fix x assume "x \<in> dependent_functions (I \<union> J) A"
  then show "restrict x I \<in> dependent_functions I A"
    by (rule dependent_functions_restrict, simp)
next
  fix x assume "x \<in> dependent_functions (I \<union> J) A"
  then show "restrict x J \<in> dependent_functions J A"
    by (rule dependent_functions_restrict, simp)
next
  fix a b assume a: "a \<in> dependent_functions I A" and b: "b \<in> dependent_functions J A"
  define x where "x i = (if i\<in>I then a i else if i\<in>J then b i else undefined)" for i
  have "x\<in>dependent_functions (I \<union> J) A"
    using a apply cases using b apply cases
    apply (rule dependent_functions'.intros)
    unfolding x_def by auto
  moreover have "a = restrict x I"
    apply (rule ext, rename_tac i)
    unfolding restrict_def x_def
    using a apply cases
    by simp
  moreover have "b = restrict x J"
    apply (rule ext, rename_tac i)
    unfolding restrict_def x_def
    using b apply cases
    using disjoint by auto
  ultimately show "\<exists>x\<in>dependent_functions (I \<union> J) A.
              a = restrict x I \<and> b = restrict x J"
    by auto
qed

lemma bij_betw_map_prod[intro]:
  assumes "bij_betw f1 A1 B1"
  assumes "bij_betw f2 A2 B2"
  shows "bij_betw (map_prod f1 f2) (A1 \<times> A2) (B1 \<times> B2)"
proof (rule bij_betw_imageI)
  show "inj_on (map_prod f1 f2) (A1 \<times> A2)"
    apply (rule map_prod_inj_on)
    using assms bij_betw_def by auto
  show "map_prod f1 f2 ` (A1 \<times> A2) = B1 \<times> B2"
    apply (rule map_prod_surj_on)
    using assms by (simp_all add: bij_betw_def)
qed

record 'a lvalue_factorization =
  lvf_domain :: "'a set"
  lvf_index_set :: "'a index set"
  lvf_sets :: "'a index \<Rightarrow> 'a factor set"
  lvf_isomorphism :: "'a \<Rightarrow> ('a index \<Rightarrow> 'a factor)"

inductive valid_lvalue_factorization :: "'a lvalue_factorization \<Rightarrow> bool" where
  "\<lbrakk> domain \<noteq> {};
     \<And>i. i\<notin>I \<Longrightarrow> sets i = undefined;
     \<And>x. x\<notin>domain \<Longrightarrow> isom x = undefined;
     bij_betw isom domain (dependent_functions I sets)
   \<rbrakk> \<Longrightarrow> valid_lvalue_factorization \<lparr> lvf_domain=domain, lvf_index_set=I, lvf_sets=sets, lvf_isomorphism=isom \<rparr>"

lemma lvalue_factorization_sets_nonempty:
  assumes valid: "valid_lvalue_factorization F"
  assumes i: "i \<in> lvf_index_set F"
  shows "lvf_sets F i \<noteq> {}"
  using valid
proof cases
  case (1 domain I sets isom)
  from i have i: "i:I" unfolding 1 by simp
  from \<open>domain \<noteq> {}\<close> and \<open>bij_betw isom domain (dependent_functions I sets)\<close>
  have "dependent_functions I sets \<noteq> {}"
    using bij_betw_empty2 by fastforce
  then obtain f where "f \<in> dependent_functions I sets" by auto
  then have "sets i \<noteq> {}"
    apply cases using i by auto
  then show ?thesis
    unfolding 1 by auto
qed

record ('a,'b) lvalue_basic =
  lv_factorization :: "'a lvalue_factorization"
  lv_factors :: "'a index set"
  lv_representation :: "('a index \<Rightarrow> 'a factor) \<Rightarrow> 'b"

inductive valid_lvalue_basic :: "('a,'b) lvalue_basic \<Rightarrow> bool" where
  "\<lbrakk> valid_lvalue_factorization factorization;
     factors \<subseteq> lvf_index_set factorization;
     inj_on repr (dependent_functions factors (lvf_sets factorization));
     \<And>x. x \<notin> (dependent_functions factors (lvf_sets factorization)) \<Longrightarrow> repr x = undefined
  \<rbrakk> \<Longrightarrow> valid_lvalue_basic \<lparr> lv_factorization=factorization, lv_factors=factors, lv_representation=repr \<rparr>"

definition "lvalue_basic_domain lv = lvf_domain (lv_factorization lv)"
definition "lvalue_basic_range lv = (lv_representation lv) ` (dependent_functions (lv_factors lv) (lvf_sets (lv_factorization lv)))"

lemma lvalue_basic_range_leq_domain:
  assumes "valid_lvalue_basic lv"
  shows "leq_card (lvalue_basic_range lv) (lvalue_basic_domain lv)"
(* TODO same for lvalue *)
  using assms
proof (cases lv)
  case (1 factorization factors repr)
  note valid = 1
  from \<open>valid_lvalue_factorization factorization\<close>
  show ?thesis
  proof cases
    case (1 domain I sets isom)
    note factor = this
    note leq_card_trans[rotated,trans]
    have "lvalue_basic_domain lv = domain"
      unfolding factor valid lvalue_basic_domain_def by simp
    also from \<open>bij_betw isom domain (dependent_functions I sets)\<close>
    have "leq_card (dependent_functions I sets) domain"
      using leq_cardI_bij' by blast
    also have "leq_card (dependent_functions factors sets) (dependent_functions I sets)"
      apply (rule dependent_functions_mono_domain)
      using factor(1) valid(3) apply auto[1]
      using factor(1) lvalue_factorization_sets_nonempty valid(2) by fastforce
    also have "leq_card (repr ` dependent_functions factors sets) (dependent_functions factors sets)"
      using factor(1) inj_on_imp_bij_betw leq_cardI_bij' valid(4) by fastforce
    also have "repr ` dependent_functions factors sets = lvalue_basic_range lv"
      unfolding factor valid lvalue_basic_range_def by simp
    finally show ?thesis by assumption
  qed
qed

inductive lvalue_basic_compatible :: "('a,'b) lvalue_basic \<Rightarrow> ('a,'c) lvalue_basic \<Rightarrow> bool" where
  "\<lbrakk> valid_lvalue_basic lv1; valid_lvalue_basic lv2;
     lv_factorization lv1 = lv_factorization lv2;
     lv_factors lv1 \<inter> lv_factors lv2 = {}
  \<rbrakk> \<Longrightarrow> lvalue_basic_compatible lv1 lv2"

lemma lvalue_basic_compatible_sym:
  assumes "lvalue_basic_compatible lvb1 lvb2"
  shows "lvalue_basic_compatible lvb2 lvb1"
  using assms apply cases apply (rule lvalue_basic_compatible.intros) by auto

fun lvalue_basic_map :: "('b\<Rightarrow>'c) \<Rightarrow> ('a,'b) lvalue_basic \<Rightarrow> ('a,'c) lvalue_basic" where
  "lvalue_basic_map f \<lparr> lv_factorization=factorization, lv_factors=factors, lv_representation=repr \<rparr>
    =  \<lparr> lv_factorization=factorization, lv_factors=factors,
         lv_representation=restrict (f o repr) (dependent_functions factors (lvf_sets factorization)) \<rparr>"

lemma lvalue_basic_map_o[simp]:
  "lvalue_basic_map f (lvalue_basic_map g lvb) = lvalue_basic_map (f o g) lvb"
  apply (cases lvb) by (auto simp: restrict_def o_def)

lemma lvalue_basic_map_cong:
  assumes "\<And>x. x\<in>lvalue_basic_range lvb \<Longrightarrow> f x = g x"
  shows "lvalue_basic_map f lvb = lvalue_basic_map g lvb"
  using assms
  apply (cases lvb)
  unfolding lvalue_basic_range_def by (auto simp: o_def restrict_def)

lemma lvalue_basic_map_id:
  assumes "valid_lvalue_basic lvb"
  shows "lvalue_basic_map id lvb = lvb"
  using assms apply (cases, hypsubst_thin)
  by (auto simp: restrict_def)

lemma valid_lvalue_basic_map:
  assumes "valid_lvalue_basic lvb"
  assumes "inj_on f (lvalue_basic_range lvb)"
  shows "valid_lvalue_basic (lvalue_basic_map f lvb)"
  using assms(1)
proof cases
  case (1 factorization factors repr)
  then have inj_repr: "inj_on repr (dependent_functions factors (lvf_sets factorization))" by simp
  have inj: "inj_on (\<lambda>x. if x \<in> dependent_functions factors (lvf_sets factorization)
                    then f (repr x) else undefined)
     (dependent_functions factors (lvf_sets factorization))"
    apply (rule inj_onI, simp)
    apply (rule inj_repr[THEN inj_onD])
      apply (rule assms(2)[THEN inj_onD])
    unfolding 1 lvalue_basic_range_def
    by auto
  show ?thesis
    unfolding 1 apply simp
    apply (rule valid_lvalue_basic.intros)
    using 1 inj by (auto simp: restrict_def[abs_def] o_def)
qed
(* TODO same for lvalue *)

lemma lvalue_basic_range_map[simp]: "lvalue_basic_range (lvalue_basic_map f lvb) = f ` lvalue_basic_range lvb"
  apply (cases lvb) by (auto simp: lvalue_basic_range_def image_image restrict_def o_def)
(* TODO same for lvalue *)
lemma lvalue_basic_domain_map[simp]: "lvalue_basic_domain (lvalue_basic_map f lvb) = lvalue_basic_domain lvb"
  apply (cases lvb) by (simp add: lvalue_basic_domain_def o_def)
(* TODO same for lvalue *)

fun lvalue_basic_fun where
  "lvalue_basic_fun \<lparr> lv_factorization=factorization, lv_factors=factors, lv_representation=repr \<rparr> x
  = repr (restrict (lvf_isomorphism factorization x) factors)"

fun lvalue_basic_corange_raw where
  "lvalue_basic_corange_raw \<lparr> lv_factorization=factorization, lv_factors=factors, lv_representation=repr \<rparr>
  = (dependent_functions (lvf_index_set factorization - factors) (lvf_sets factorization))"

definition lvalue_basic_cofun_squash :: "('a, 'b) lvalue_basic \<Rightarrow> ('a OldLValue.index \<Rightarrow> 'a factor) \<Rightarrow> 'a"  where
  "lvalue_basic_cofun_squash lv = (SOME f. inj_on f (lvalue_basic_corange_raw lv))"

lemma lvalue_basic_cofun_squash:
  assumes "valid_lvalue_basic lvb"
  shows "inj_on (lvalue_basic_cofun_squash lvb) (lvalue_basic_corange_raw lvb)"
  using assms
proof cases
  case (1 factorization factors repr)
  note lvb = 1
  from \<open>valid_lvalue_factorization factorization\<close>
  have "leq_card (lvalue_basic_corange_raw lvb) (UNIV::'a set)"
  proof cases
    case (1 domain I sets isom)
    have "lvalue_basic_corange_raw lvb = dependent_functions (I - factors) sets"
      unfolding lvb 1 by simp
    also have "leq_card \<dots> (dependent_functions I sets)"
      apply (rule leq_cardI_surj[where f="%f. restrict f (I-factors)"])
      apply (rule equalityD2)
      apply (rule dependent_functions_restrict_surj)
      apply auto[1]
      using "1"(1) lvalue_factorization_sets_nonempty lvb(2) by fastforce
    also have "leq_card \<dots> domain"
      using \<open>bij_betw isom domain (dependent_functions I sets)\<close>
      using leq_cardI_bij' by auto
    also have "leq_card \<dots> (UNIV::'a set)"
      by simp
    finally show ?thesis.
  qed
  then have "\<exists>f::_\<Rightarrow>'a. inj_on f (lvalue_basic_corange_raw lvb)"
    unfolding leq_card_def by auto
  then show ?thesis
    unfolding lvalue_basic_cofun_squash_def
    by (rule someI_ex[where P="%f. inj_on f (lvalue_basic_corange_raw lvb)"])
qed

fun lvalue_basic_corange where
  "lvalue_basic_corange lv = lvalue_basic_cofun_squash lv ` lvalue_basic_corange_raw lv"

fun lvalue_basic_cofun_raw where
  "lvalue_basic_cofun_raw \<lparr> lv_factorization=factorization, lv_factors=factors, lv_representation=repr \<rparr> x
    = restrict (lvf_isomorphism factorization x) (lvf_index_set factorization - factors)"

definition "lvalue_basic_cofun lv x = (lvalue_basic_cofun_squash lv (lvalue_basic_cofun_raw lv x))"

lemma lvalue_basic_fun_raw_bij:
  assumes "valid_lvalue_basic lvb"
  shows "bij_betw (\<lambda>x. (lvalue_basic_fun lvb x, lvalue_basic_cofun_raw lvb x))
                  (lvalue_basic_domain lvb) (lvalue_basic_range lvb \<times> lvalue_basic_corange_raw lvb)"
  using assms
proof cases
  case (1 factorization factors repr)
  note lvb = 1
  from \<open>valid_lvalue_factorization factorization\<close>
  show ?thesis
  proof cases
    case (1 domain I sets isom)
    note factorization = 1
    note bij_betw_trans[trans]
    from 1 have "bij_betw isom domain (dependent_functions I sets)" by simp
    also have "bij_betw (\<lambda>f. (restrict f factors, restrict f (I-factors)))
      (dependent_functions I sets)
      (dependent_functions factors sets \<times> dependent_functions (I-factors) sets)"
    proof -
      have uni: "I = factors \<union> (I-factors)"
        using factorization(1) lvb(3) by auto
      show ?thesis
        apply (subst uni, rule dependent_functions_split)
        by simp
    qed
    also
    have "bij_betw (map_prod repr id)
        (dependent_functions factors sets \<times> dependent_functions (I-factors) sets)
        (lvalue_basic_range lvb \<times> lvalue_basic_corange_raw lvb)"
    proof -
      have inj: "inj_on (map_prod repr id) (dependent_functions factors sets \<times> dependent_functions (I - factors) sets)"
        apply (rule map_prod_inj_on)
        using factorization(1) lvb(4) by auto
      show ?thesis
        unfolding lvb factorization
        apply  (simp add: lvalue_basic_domain_def lvalue_basic_range_def o_def)
        using inj apply (rule bij_betw_imageI)
        by (simp add: map_prod_surj_on)
    qed
    finally show ?thesis
      unfolding lvb factorization
      by (simp add: lvalue_basic_domain_def lvalue_basic_range_def o_def)
  qed
qed

lemma lvalue_basic_fun_bij:
  assumes "valid_lvalue_basic lvb"
  shows "bij_betw (\<lambda>x. (lvalue_basic_fun lvb x, lvalue_basic_cofun lvb x))
                  (lvalue_basic_domain lvb) (lvalue_basic_range lvb \<times> lvalue_basic_corange lvb)"
(* TODO same for lvalue *)
proof -
  note bij_betw_trans[trans]
  note lvalue_basic_fun_raw_bij[OF assms]
  also have "bij_betw (apsnd (lvalue_basic_cofun_squash lvb))
                      (lvalue_basic_range lvb \<times> lvalue_basic_corange_raw lvb)
                      (lvalue_basic_range lvb \<times> lvalue_basic_corange lvb)"
    unfolding lvalue_basic_cofun_squash apsnd_def
    apply (rule bij_betw_map_prod)
    by (auto simp: assms inj_on_imp_bij_betw lvalue_basic_cofun_squash)
  finally show ?thesis
    unfolding lvalue_basic_cofun_def o_def by simp
qed

fun lvalue_basic_compose :: "('a,'b) lvalue_basic \<Rightarrow> ('a,'c) lvalue_basic \<Rightarrow> ('a,'b*'c) lvalue_basic" where
  "lvalue_basic_compose \<lparr> lv_factorization=factorization1, lv_factors=factors1, lv_representation=repr1 \<rparr>
                        \<lparr> lv_factorization=factorization2, lv_factors=factors2, lv_representation=repr2 \<rparr>
    =  \<lparr> lv_factorization=factorization1, lv_factors=factors1 \<union> factors2,
         lv_representation=restrict (\<lambda>x. (repr1 (restrict x factors1),
                                          repr2 (restrict x factors2)))
                                      (dependent_functions (factors1\<union>factors2) (lvf_sets factorization1)) \<rparr>"

lemma lvalue_basic_compose_fun:
  assumes compat: "lvalue_basic_compatible lv1 lv2"
  assumes x: "x : lvalue_basic_domain lv1"
  shows "lvalue_basic_fun (lvalue_basic_compose lv1 lv2) x = (lvalue_basic_fun lv1 x, lvalue_basic_fun lv2 x)"
  using assms
(* TODO same for lvalue *)
proof cases
  from compat have same_fact: "lv_factorization lv1 = lv_factorization lv2" by cases
  obtain factorization factors1 repr1 where
    lv1: "lv1 = \<lparr> lv_factorization=factorization, lv_factors=factors1, lv_representation=repr1 \<rparr>"
    apply atomize_elim apply (cases lv1) by simp
  with same_fact obtain factors2 repr2 where
    lv2: "lv2 = \<lparr> lv_factorization=factorization, lv_factors=factors2, lv_representation=repr2 \<rparr>"
    apply atomize_elim apply (cases lv1) apply auto
    by (metis (full_types) lvalue_basic.surjective old.unit.exhaust)

  from compat have factors_disj: "factors1 \<inter> factors2 = {}" apply cases unfolding lv1 lv2 by simp

  from compat have valid1: "valid_lvalue_basic lv1" apply cases by simp
  then have "valid_lvalue_factorization factorization" unfolding lv1 apply cases by simp
  then obtain domain I sets isom where
    factorization: "factorization = \<lparr>lvf_domain = domain, lvf_index_set = I, lvf_sets = sets, lvf_isomorphism = isom\<rparr>"
    and "domain \<noteq> {}"
    and "\<And>i. i \<notin> I \<Longrightarrow> sets i = undefined"
    and "\<And>x. x \<notin> domain \<Longrightarrow> isom x = undefined"
    and bij: "bij_betw isom domain (dependent_functions I sets)"
    apply cases by auto

  from valid1 have factors1: "factors1 \<subseteq> I" unfolding lv1 apply cases by (auto simp: factorization)
  from compat have valid2: "valid_lvalue_basic lv2" apply cases by simp
  from valid2 have factors2: "factors2 \<subseteq> I" unfolding lv2 apply cases by (auto simp: factorization)

  from x have x: "x \<in> domain"
    unfolding lv1 lvalue_basic_domain_def factorization by simp

  have restrict: "restrict (isom x) (factors1 \<union> factors2)
    \<in> dependent_functions (factors1 \<union> factors2) sets"
    apply (rule dependent_functions_restrict[where D=I])
    using bij x bij_betwE factorization apply auto[1]
    using factors1 factors2 by simp

  have "fst (lvalue_basic_fun (lvalue_basic_compose lv1 lv2) x) = lvalue_basic_fun lv1 x"
    unfolding lv1 lv2 using factors_disj by (auto intro: restrict simp: factorization restrict_def Int_commute)
  moreover have "snd (lvalue_basic_fun (lvalue_basic_compose lv1 lv2) x) = lvalue_basic_fun lv2 x"
    unfolding lv1 lv2 using factors_disj by (auto intro: restrict simp: factorization restrict_def inf_sup_distrib2)
  ultimately show ?thesis
    by (metis prod.collapse)
qed

lemma lvalue_basic_compose_valid:
  assumes "lvalue_basic_compatible lv1 lv2"
  shows "valid_lvalue_basic (lvalue_basic_compose lv1 lv2)"
(* TODO same for lvalue *)
proof -
  from assms have same_fact: "lv_factorization lv1 = lv_factorization lv2" by cases
  obtain factorization factors1 repr1 where
    lv1: "lv1 = \<lparr> lv_factorization=factorization, lv_factors=factors1, lv_representation=repr1 \<rparr>"
    apply atomize_elim apply (cases lv1) by simp
  with same_fact obtain factors2 repr2 where
    lv2: "lv2 = \<lparr> lv_factorization=factorization, lv_factors=factors2, lv_representation=repr2 \<rparr>"
    apply atomize_elim apply (cases lv1) apply auto
    by (metis (full_types) lvalue_basic.surjective old.unit.exhaust)

  from assms have valid1: "valid_lvalue_basic lv1" by cases
  then have valid_fact: "valid_lvalue_factorization factorization"
    apply cases unfolding lv1 by simp
  from valid1 have inj_repr1: "inj_on repr1 (dependent_functions factors1 (lvf_sets factorization))"
    apply cases unfolding lv1 by simp

  from assms have valid2: "valid_lvalue_basic lv2" by cases
  from valid2 have inj_repr2: "inj_on repr2 (dependent_functions factors2 (lvf_sets factorization))"
    apply cases unfolding lv2 by simp

  have fact_union: "factors1 \<union> factors2 \<subseteq> lvf_index_set factorization"
    by (metis Un_subset_iff assms lv1 lv2 lvalue_basic.select_convs(1) lvalue_basic.select_convs(2) lvalue_basic_compatible.cases valid_lvalue_basic.cases)

  have inj: "inj_on
     (restrict (\<lambda>x. (repr1 (restrict x factors1), repr2 (restrict x factors2)))
       (dependent_functions (factors1 \<union> factors2) (lvf_sets factorization)))
     (dependent_functions (factors1 \<union> factors2) (lvf_sets factorization))"
    apply (subst inj_on_restrict)
(* TODO apply rule that removes the restrict. Like inj_on (restrict f I) I = inj_on f I. *)
  proof (rule inj_onI, rule ext)
    fix x y i
    assume x: "x \<in> dependent_functions (factors1 \<union> factors2) (lvf_sets factorization)"
    then have x_factors1: "restrict x factors1 : dependent_functions factors1 (lvf_sets factorization)"
          and x_factors2: "restrict x factors2 : dependent_functions factors2 (lvf_sets factorization)"
      using dependent_functions_restrict by auto
    assume y: "y \<in> dependent_functions (factors1 \<union> factors2) (lvf_sets factorization)"
    then have y_factors1: "restrict y factors1 : dependent_functions factors1 (lvf_sets factorization)"
          and y_factors2: "restrict y factors2 : dependent_functions factors2 (lvf_sets factorization)"
      using dependent_functions_restrict by auto
    assume eq: "(repr1 (restrict x factors1), repr2 (restrict x factors2)) =
            (repr1 (restrict y factors1), repr2 (restrict y factors2))"
    then have "repr1 (restrict x factors1) = repr1 (restrict y factors1)"
      by simp
    from inj_repr1 this x_factors1 y_factors1
    have eq1: "restrict x factors1 = restrict y factors1"
      by (rule inj_onD[where f=repr1])
    from eq have "repr2 (restrict x factors2) = repr2 (restrict y factors2)"
      by simp
    from inj_repr2 this x_factors2 y_factors2
    have eq2: "restrict x factors2 = restrict y factors2"
      by (rule inj_onD[where f=repr2])

    consider (factors1) "i \<in> factors1" | (factors2) "i \<in> factors2" | (outside) "i \<notin> factors1 \<union> factors2"
      by auto
    then show "x i = y i"
    proof cases
      case factors1
      with eq1[THEN fun_cong, of i]
      show ?thesis
        unfolding restrict_def by simp
    next
      case factors2
      with eq2[THEN fun_cong, of i]
      show ?thesis
        unfolding restrict_def by simp
    next
      case outside
      with x have xi: "x i = undefined"
        apply cases by simp
      from y outside have yi: "y i = undefined"
        apply cases by simp
      from xi yi show ?thesis
        by simp
    qed
  qed

  have outside: "f \<notin> dependent_functions (factors1 \<union> factors2) (lvf_sets factorization) \<Longrightarrow>
         restrict (\<lambda>x. (repr1 (restrict x factors1), repr2 (restrict x factors2)))
          (dependent_functions (factors1 \<union> factors2) (lvf_sets factorization)) f =
         undefined" for f
    unfolding restrict_def by simp

  show ?thesis
    unfolding lv1 lv2 apply simp
    using valid_fact fact_union inj outside by (rule valid_lvalue_basic.intros)
qed

lemma lvalue_basic_domain_compose:
  assumes compat: "lvalue_basic_compatible lvb1 lvb2"
  shows "lvalue_basic_domain (lvalue_basic_compose lvb1 lvb2) = lvalue_basic_domain lvb1"
    and "lvalue_basic_domain (lvalue_basic_compose lvb1 lvb2) = lvalue_basic_domain lvb2"
   apply (cases lvb1, cases lvb2, hypsubst_thin, simp add: lvalue_basic_domain_def)
  apply (insert compat)
  by (cases lvb1, cases lvb2, hypsubst_thin, simp add: lvalue_basic_domain_def lvalue_basic_compatible.simps)
(* TODO same for lvalue *)

lemma lvalue_basic_range_compose:
  assumes compat: "lvalue_basic_compatible lvb1 lvb2"
  shows "lvalue_basic_range (lvalue_basic_compose lvb1 lvb2)
           = lvalue_basic_range lvb1 \<times> lvalue_basic_range lvb2"
(* TODO same for lvalue *)
proof -
  from assms have same_fact: "lv_factorization lvb1 = lv_factorization lvb2" by cases
  obtain factorization factors1 repr1 where
    lv1: "lvb1 = \<lparr> lv_factorization=factorization, lv_factors=factors1, lv_representation=repr1 \<rparr>"
    apply atomize_elim apply (cases lvb1) by simp
  with same_fact obtain factors2 repr2 where
    lv2: "lvb2 = \<lparr> lv_factorization=factorization, lv_factors=factors2, lv_representation=repr2 \<rparr>"
    apply atomize_elim apply (cases lvb1) apply auto
    by (metis (full_types) lvalue_basic.surjective old.unit.exhaust)

  from assms have factors_disj: "factors1 \<inter> factors2 = {}" apply cases unfolding lv1 lv2 by simp

  have "(\<lambda>x. (restrict x factors1, restrict x factors2)) `
        dependent_functions (factors1 \<union> factors2) (lvf_sets factorization) =
            dependent_functions factors1 (lvf_sets factorization) \<times>
            dependent_functions factors2 (lvf_sets factorization)"
    using dependent_functions_split[OF factors_disj, where A="lvf_sets factorization"]
    by (simp add: bij_betw_def)
  also have "(map_prod repr1 repr2) ` \<dots> = lvalue_basic_range lvb1 \<times> lvalue_basic_range lvb2"
    apply (rule map_prod_surj_on)
    unfolding lvalue_basic_range_def lv1 lv2 by simp_all
  finally show ?thesis
    unfolding lvalue_basic_range_def lv1 lv2
    unfolding map_prod_def image_comp o_def by (simp add: restrict_image)
qed

definition lvalue_basic_squash :: "('a,'b) lvalue_basic \<Rightarrow> ('a,'a) lvalue_basic * ('a\<Rightarrow>'b)" where
  "lvalue_basic_squash lv =
    (let f::'b\<Rightarrow>'a = SOME f. inj_on f (lvalue_basic_range lv);
         lv' = lvalue_basic_map f lv;
         f' = inv_into (lvalue_basic_range lv) f
     in (lv',f'))"

lemma lvalue_basic_squash_bij:
  assumes "valid_lvalue_basic lvb"
  shows "bij_betw (snd (lvalue_basic_squash lvb))
            (lvalue_basic_range (fst (lvalue_basic_squash lvb)))
            (lvalue_basic_range lvb)"
proof -
  define f :: "'b\<Rightarrow>'a" and lvb' and f' where "f = (SOME f. inj_on f (lvalue_basic_range lvb))"
    and "lvb' = lvalue_basic_map f lvb"
    and "f' = inv_into (lvalue_basic_range lvb) f"
  then have squash: "lvalue_basic_squash lvb = (lvb',f')"
    unfolding lvalue_basic_squash_def unfolding Let_def by simp
  have "inj_on f (lvalue_basic_range lvb)"
    unfolding f_def apply (rule someI_ex[where P="%f. inj_on f (lvalue_basic_range lvb)"])
    using lvalue_basic_range_leq_domain[OF assms]
    unfolding leq_card_def by auto
  then have "bij_betw f (lvalue_basic_range lvb) (lvalue_basic_range lvb')"
    unfolding lvb'_def
    by (simp add: inj_on_imp_bij_betw)
  then have "bij_betw f' (lvalue_basic_range lvb') (lvalue_basic_range lvb)"
    unfolding f'_def
    by (rule bij_betw_inv_into)
  then show ?thesis
    unfolding squash by simp
qed

lemma lvalue_basic_squash_map:
  assumes "valid_lvalue_basic lvb"
  shows "lvalue_basic_map (snd (lvalue_basic_squash lvb)) (fst (lvalue_basic_squash lvb)) = lvb"
proof -
  define f :: "'b\<Rightarrow>'a" and lvb' and f' where "f = (SOME f. inj_on f (lvalue_basic_range lvb))"
    and "lvb' = lvalue_basic_map f lvb"
    and "f' = inv_into (lvalue_basic_range lvb) f"
  then have squash: "lvalue_basic_squash lvb = (lvb',f')"
    unfolding lvalue_basic_squash_def unfolding Let_def by simp
  have "inj_on f (lvalue_basic_range lvb)"
    unfolding f_def apply (rule someI_ex[where P="%f. inj_on f (lvalue_basic_range lvb)"])
    using lvalue_basic_range_leq_domain[OF assms]
    unfolding leq_card_def by auto
  then have bij_f: "bij_betw f (lvalue_basic_range lvb) (lvalue_basic_range lvb')"
    unfolding lvb'_def
    by (simp add: inj_on_imp_bij_betw)

  have "f' (f x) = x" if "x \<in> lvalue_basic_range lvb" for x
    unfolding f'_def
    using bij_f that by (rule bij_betw_inv_into_left)
  then have "lvalue_basic_map (f' \<circ> f) lvb = lvb"
    apply (subst (2) lvalue_basic_map_id[OF assms, symmetric])
    apply (rule lvalue_basic_map_cong)
    by auto
  then show ?thesis
    unfolding squash lvb'_def by simp
qed

datatype ('a,'b) lvalue =
  LValueBasic "('a,'b) lvalue_basic"
  (* LValueChained lv lvb = lv o lvb *)
  | LValueChained "('a,'b) lvalue" "('a,'a) lvalue_basic"

fun lvalue_domain where
  "lvalue_domain (LValueBasic lvb) = lvalue_basic_domain lvb"
| "lvalue_domain (LValueChained lv lvb) = lvalue_basic_domain lvb"

fun lvalue_range where
  "lvalue_range (LValueBasic lvb) = lvalue_basic_range lvb"
| "lvalue_range (LValueChained lv lvb) = lvalue_range lv"

fun lvalue_map where
  "lvalue_map f (LValueBasic lvb) = LValueBasic (lvalue_basic_map f lvb)"
| "lvalue_map f (LValueChained lv lvb) = LValueChained (lvalue_map f lv) lvb"

inductive valid_lvalue where
  "valid_lvalue_basic lvb \<Longrightarrow> valid_lvalue (LValueBasic lvb)"
| "\<lbrakk> valid_lvalue lv; valid_lvalue_basic lvb; lvalue_domain lv = lvalue_basic_range lvb \<rbrakk>
       \<Longrightarrow> valid_lvalue (LValueChained lv lvb)"

definition lvalue_compose :: "('a,'b) lvalue \<Rightarrow> ('a,'c) lvalue \<Rightarrow> ('a,'b*'c) lvalue" where
  "lvalue_compose = undefined" (* TODO *)

fun lvalue_squash where
  "lvalue_squash (LValueBasic lvb) = (let (lvb',f) = lvalue_basic_squash lvb in (LValueBasic lvb', f))"
| "lvalue_squash (LValueChained lv lvb) = (let (lv',f) = lvalue_squash lv in (LValueChained lv' lvb, f))"

lemma lvalue_squash_bij:
  assumes "valid_lvalue lv"
  shows "bij_betw (snd (lvalue_squash lv)) (lvalue_range (fst (lvalue_squash lv))) (lvalue_range lv)"
proof (insert assms, induction lv)
  case (LValueBasic x)
  then show ?case
    apply cases
    apply (simp add: case_prod_beta)
    by (simp add: lvalue_basic_squash_bij)
next
  case (LValueChained lv x2)
  from LValueChained.prems have valid: "valid_lvalue lv" by cases
  show ?case
    apply (simp add: case_prod_beta)
    apply (rule LValueChained.IH)
    by (fact valid)
qed

lemma lvalue_squash_map:
  assumes "valid_lvalue lv"
  shows "lvalue_map (snd (lvalue_squash lv)) (fst (lvalue_squash lv)) = lv"
proof (insert assms, induction lv)
  case (LValueBasic lvb)
  then have valid: "valid_lvalue_basic lvb"
    by cases
  show ?case
    apply (simp add: case_prod_beta)
    apply (rule lvalue_basic_squash_map)
    by (fact valid)
next
  case (LValueChained lv x2)
  from LValueChained.prems have valid: "valid_lvalue lv" by cases
  show ?case
    apply (simp add: case_prod_beta)
    apply (rule LValueChained.IH)
    by (fact valid)
qed

definition lvalue_basic_domain_map :: "('a\<Rightarrow>'b) \<Rightarrow> ('b,'c) lvalue_basic \<Rightarrow> ('a,'c) lvalue_basic" where
"lvalue_basic_domain_map = undefined" (* TODO *)

fun lvalue_chain_basic :: "('b,'c) lvalue_basic \<Rightarrow> ('a,'b) lvalue \<Rightarrow> ('a,'c) lvalue" where
  "lvalue_chain_basic lvb1 (LValueBasic lvb2) = (let (lvb2',f) = lvalue_basic_squash lvb2 in
    LValueChained (LValueBasic (lvalue_basic_domain_map f lvb1)) lvb2')"
| "lvalue_chain_basic lvb1 (LValueChained lv2 lvb2) = LValueChained (lvalue_chain_basic lvb1 lv2) lvb2"

fun lvalue_chain where
  "lvalue_chain (LValueBasic lvb1) lv2 = lvalue_chain_basic lvb1 lv2"
| "lvalue_chain (LValueChained lv1 lvb1) lv2 = lvalue_chain lv1 (lvalue_chain_basic lvb1 lv2)"

inductive lvalue_compatible :: "('a,'b) lvalue \<Rightarrow> ('a,'c) lvalue \<Rightarrow> bool" where
  lvalue_compatible_same: "lvalue_compatible lv1 lv2 \<Longrightarrow> lvalue_compatible (LValueChained lv1 lvb) (LValueChained lv2 lvb)"
| lvalue_compatible_cc: "lvalue_basic_compatible lvb1 lvb2 \<Longrightarrow> lvalue_compatible (LValueChained lv1 lvb1) (LValueChained lv2 lvb2)"
| lvalue_compatible_bb: "lvalue_basic_compatible lvb1 lvb2 \<Longrightarrow> lvalue_compatible (LValueBasic lvb1) (LValueBasic lvb2)"
| lvalue_compatible_cb: "lvalue_basic_compatible lvb1 lvb2 \<Longrightarrow> lvalue_compatible (LValueChained lv1 lvb1) (LValueBasic lvb2)"
| lvalue_compatible_bc: "lvalue_basic_compatible lvb1 lvb2 \<Longrightarrow> lvalue_compatible (LValueBasic lvb1) (LValueChained lv2 lvb2)"

lemma lvalue_compatible_sym:
  assumes "lvalue_compatible lv1 lv2"
  shows "lvalue_compatible lv2 lv1"
  using assms proof induction
  case (lvalue_compatible_same lv1 lv2 lvb)
  then show ?case
    by (rule_tac lvalue_compatible.lvalue_compatible_same, simp)
next
  case (lvalue_compatible_cc lvb1 lvb2 lv1 lv2)
  then show ?case
    apply (rule_tac lvalue_compatible.intros)
    by (rule lvalue_basic_compatible_sym)
next
case (lvalue_compatible_bb lvb1 lvb2)
  then show ?case
    apply (rule_tac lvalue_compatible.intros)
    by (rule lvalue_basic_compatible_sym)
next
  case (lvalue_compatible_cb lvb1 lvb2 lv1)
  then show ?case
    apply (rule_tac lvalue_compatible.intros)
    by (rule lvalue_basic_compatible_sym)
next
case (lvalue_compatible_bc lvb1 lvb2 lv2)
  then show ?case
    apply (rule_tac lvalue_compatible.intros)
    by (rule lvalue_basic_compatible_sym)
qed

fun lvalue_fun :: "('a, 'b) lvalue \<Rightarrow> 'a \<Rightarrow> 'b" where
  "lvalue_fun (LValueBasic lvb) x = lvalue_basic_fun lvb x"
| "lvalue_fun (LValueChained lv lvb) x = lvalue_fun lv (lvalue_basic_fun lvb x)"

fun lvalue_cofun :: "('a, 'b) lvalue \<Rightarrow> 'a \<Rightarrow> 'a"
  and "lvalue_corange" :: "('a, 'b) lvalue \<Rightarrow> 'a set"
where
  "lvalue_cofun (LValueBasic lvb) x = lvalue_basic_cofun lvb x"
| "lvalue_cofun (LValueChained lv lvb) x =
    (let y = lvalue_basic_fun lvb x;
         yco = lvalue_basic_cofun lvb x;
         zco = lvalue_cofun lv y;
         f = SOME f. inj_on f (lvalue_basic_corange lvb \<times> lvalue_corange lv)
     in f (yco,zco))"
| "lvalue_corange (LValueBasic lvb) = lvalue_basic_corange lvb"
| "lvalue_corange (LValueChained lv lvb) =
    (let f = SOME f. inj_on f (lvalue_basic_corange lvb \<times> lvalue_corange lv)
    in f ` (lvalue_basic_corange lvb \<times> lvalue_corange lv))"

section Matrices

typedef 'a matrix = "UNIV::('a\<Rightarrow>'a\<Rightarrow>complex) set" by simp
setup_lifting type_definition_matrix

lift_definition tensor :: "'a::finite matrix \<Rightarrow> 'b::finite matrix \<Rightarrow> ('a*'b) matrix" is
  "%A B. \<lambda>(r1,r2) (c1,c2). A r1 c1 * B r2 c2" .

instantiation matrix :: (type) ab_group_add begin
lift_definition plus_matrix :: "'a matrix \<Rightarrow> 'a matrix \<Rightarrow> 'a matrix" is "%A B i j. A i j + B i j".
lift_definition minus_matrix :: "'a matrix \<Rightarrow> 'a matrix \<Rightarrow> 'a matrix" is "%A B i j. A i j - B i j".
lift_definition uminus_matrix :: "'a matrix \<Rightarrow> 'a matrix" is "%A i j. - A i j".
lift_definition zero_matrix :: "'a matrix" is "\<lambda>i j. 0".
instance sorry
end

instantiation matrix :: (type) "{times,one}" begin
lift_definition times_matrix :: "'a matrix \<Rightarrow> 'a matrix \<Rightarrow> 'a matrix" is "%A B i k. (\<Sum>j\<in>UNIV. A i j * B j k)".
lift_definition one_matrix :: "'a matrix" is "\<lambda>i j. if i=j then 1 else 0".
instance apply intro_classes.
end

instantiation matrix :: (finite) ring_1 begin
instance apply intro_classes sorry
end

axiomatization
  fst_lvalue :: "('a*'b, 'a) lvalue" and
  snd_lvalue :: "('a*'b, 'b) lvalue" where
  valid_fst_lvalue: "valid_lvalue fst_lvalue" and
  valid_snd_lvalue: "valid_lvalue snd_lvalue" and
  compatible_fst_snd: "lvalue_compatible fst_lvalue snd_lvalue"

lemma compatible_snd_fst: "lvalue_compatible snd_lvalue fst_lvalue"
  using compatible_fst_snd by (rule lvalue_compatible_sym)

abbreviation "delta x y == (if x=y then 1 else 0)"

lift_definition matrix_on :: "'b::finite matrix \<Rightarrow> ('a,'b) lvalue \<Rightarrow> 'a matrix" is
  "\<lambda>B lv (r::'a) (c::'a). B (lvalue_fun lv r) (lvalue_fun lv c)
  * delta (lvalue_cofun lv r) (lvalue_cofun lv c)" .

lemma matrix_on_lift_left:
  assumes compat: "compatible_lvaluex x y"
  assumes domain[simp]: "lvalue_domain x = UNIV"
  defines "xy == lvalue_compose x y"
  shows "matrix_on A x = matrix_on (tensor A 1) xy"
proof (transfer fixing: x y xy, rule ext, rule ext)
  fix A :: "'b \<Rightarrow> 'b \<Rightarrow> complex" and r c
  define Rx where "Rx = (\<lambda>i. (lvalue_fun x i, lvalue_cofun x i))"
  define Rxy where "Rxy = (\<lambda>i. (lvalue_fun xy i, lvalue_cofun xy i))"
  from composed_lvalue_relationship_left[OF compat]
  obtain f f' where f: "left_composition_f x y f f'"
    by auto
  have valid_xy: "valid_lvalue xy"
    unfolding xy_def using compat by (rule valid_lvalue_compose)
  note left_composition_f_inv_inj[OF f, folded xy_def Rxy_def, simp]
  have map: "Rx z = left_composition_map_back f' (Rxy z)" if "z \<in> lvaluex_domain x" for z
    unfolding Rx_def Rxy_def xy_def
    using f that by (rule left_composition_map_back)
  show "A (lvalue_fun x r) (lvalue_fun x c) * delta (lvalue_cofun x r) (lvalue_cofun x c) =
       (case lvalue_fun xy r of (r1, r2) \<Rightarrow> \<lambda>(c1, c2). A r1 c1 * delta r2 c2) (lvalue_fun xy c) *
       delta (lvalue_cofun xy r) (lvalue_cofun xy c)"
    apply (subst map, simp)+
    apply (cases "Rxy r", cases "Rxy c")
    unfolding left_composition_map_back_def
    by auto
qed

lemma matrix_on_lift_right:
  assumes (* "valid_lvaluex x" and "valid_lvaluex y" and *) compat: "compatible_lvaluex x y"
  assumes domain[simp]: "lvaluex_domain y = UNIV"
  defines "xy == compose_lvaluex x y"
  shows "matrix_on A y = matrix_on (tensor 1 A) xy"
proof (transfer fixing: x y xy, rule ext, rule ext)
  fix A :: "'c \<Rightarrow> 'c \<Rightarrow> complex" and r c
  define Ry where "Ry = lvaluex_representation y"
  define Rxy where "Rxy = lvaluex_representation xy"
  from composed_lvalue_relationship_right[OF compat]
  obtain f f' where f: "right_composition_f x y f f'"
    by auto
  have valid_xy: "valid_lvaluex xy"
    unfolding xy_def using compat by (rule valid_compose_lvaluex)
  note right_composition_f_inv_inj[OF f, folded xy_def Rxy_def, simp]
  have map: "Ry z = right_composition_map_back f' (Rxy z)" if "z \<in> lvaluex_domain y" for z
    unfolding Ry_def Rxy_def xy_def
    using f that by (rule right_composition_map_back)
  show "A (fst (Ry r)) (fst (Ry c)) * delta (snd (Ry r)) (snd (Ry c)) =
       (case fst (Rxy r) of (r1, r2) \<Rightarrow> \<lambda>(c1, c2). delta r1 c1 * A r2 c2)
        (fst (Rxy c)) * delta (snd (Rxy r)) (snd (Rxy c))"
    apply (subst map, simp)+
    apply (cases "Rxy r", cases "Rxy c")
    unfolding right_composition_map_back_def
    by auto
qed

lemma tensor_distrib: "(tensor A B) * (tensor C D) = tensor (A * C) (B * D)"
proof (transfer, rule ext, rule ext)
  fix A C :: "'a\<Rightarrow>'a\<Rightarrow>complex" and B D :: "'b\<Rightarrow>'b\<Rightarrow>complex" and i k :: "'a*'b"
  obtain i1 i2 k1 k2 where i: "i=(i1,i2)" and k: "k=(k1,k2)" by force
  have "(\<Sum>j\<in>UNIV.
          (case i of (r1, r2) \<Rightarrow> \<lambda>(c1, c2). A r1 c1 * B r2 c2) j *
          (case j of (r1, r2) \<Rightarrow> \<lambda>(c1, c2). C r1 c1 * D r2 c2) k)
        =
          (\<Sum>(j1,j2)\<in>UNIV. (A i1 j1 * B i2 j2) * (C j1 k1 * D j2 k2))" (is "?lhs = _")
    unfolding i k by (auto simp: case_prod_beta)
  also have "\<dots> = (\<Sum>j1\<in>UNIV. \<Sum>j2\<in>UNIV. (A i1 j1 * C j1 k1) * (B i2 j2 * D j2 k2))"
    unfolding UNIV_Times_UNIV[symmetric] sum.cartesian_product[symmetric]
    by (meson semiring_normalization_rules(13) sum.cong)
  also have "\<dots> = (\<Sum>j1\<in>UNIV. A i1 j1 * C j1 k1) * (\<Sum>j2\<in>UNIV. B i2 j2 * D j2 k2)"
    by (simp add: sum_product)
  also have "... = (case i of (r1, r2) \<Rightarrow> \<lambda>(c1, c2). (\<Sum>j\<in>UNIV. A r1 j * C j c1) * (\<Sum>j\<in>UNIV. B r2 j * D j c2)) k"  (is "_ = ?rhs")
    unfolding i k by simp
  finally
  show "?lhs = ?rhs" by assumption
qed

lemma matrix_on_times:
  fixes x :: "('a::finite, 'b::finite) lvaluex"
  assumes valid_x: "valid_lvaluex x"
  assumes domain[simp]: "lvaluex_domain x = UNIV"
  assumes range[simp]: "lvaluex_range x = UNIV"
  shows "matrix_on A x * matrix_on B x = matrix_on (A*B) x"
proof (transfer fixing: x, rule ext, rule ext)
  fix A B :: "'b \<Rightarrow> 'b \<Rightarrow> complex" and i k
  define Rx rg corg where "Rx = lvaluex_representation x"
    and "rg = lvaluex_range x" and "corg = lvaluex_representation_range x"
  obtain i1 i2 where i: "Rx i = (i1, i2)" by force
  obtain k1 k2 where k: "Rx k = (k1, k2)" by force
  have Rx_bij: "bij_betw Rx UNIV (UNIV \<times> corg)"
    unfolding Rx_def domain[symmetric] range[symmetric] corg_def
    using valid_x by (rule bij_lvaluex_representation)
  have "(\<Sum>j\<in>UNIV \<times> corg. A i1 (fst j) * delta k2 (snd j) * (B (fst j) k1 * delta (snd j) k2)) =
        (\<Sum>j1\<in>UNIV. \<Sum>j2\<in>corg. A i1 j1 * delta k2 j2 * (B j1 k1 * delta j2 k2))"
    apply (subst sum.cartesian_product) by (auto simp: case_prod_beta)
  also have "\<dots> = (\<Sum>j1\<in>UNIV. \<Sum>j2\<in>corg. (A i1 j1 * B j1 k1) * (delta k2 j2 * delta j2 k2))"
    by (meson semiring_normalization_rules(13) sum.cong)
  also have "\<dots> = (\<Sum>j1\<in>UNIV. A i1 j1 * B j1 k1) * (\<Sum>j2\<in>corg. delta k2 j2 * delta j2 k2)"
    by (simp add: sum_product)
  also have "(\<Sum>j2\<in>corg. delta k2 j2 * delta j2 k2 :: complex) = (\<Sum>j2\<in>{k2}. delta k2 j2 * delta j2 k2)"
    apply (rule sum.mono_neutral_cong_right)
       apply simp
    using Rx_bij k
      apply (metis SigmaD2 bij_betw_def rangeI singletonD subset_eq)
    by auto
  also have "(\<Sum>j1\<in>UNIV. A i1 j1 * B j1 k1) * (\<Sum>j2\<in>{k2}. delta k2 j2 * delta j2 k2) = (\<Sum>j1\<in>UNIV. A i1 j1 * B j1 k1)"
    by simp
  also note eq = calculation
  show "(\<Sum>j\<in>UNIV.
          A (fst (Rx i)) (fst (Rx j)) * delta (snd (Rx i)) (snd (Rx j)) *
          (B (fst (Rx j)) (fst (Rx k)) * delta (snd (Rx j)) (snd (Rx k)))) =
       (\<Sum>j\<in>UNIV. A (fst (Rx i)) j * B j (fst (Rx k))) * delta (snd (Rx i)) (snd (Rx k))"
    apply (subst sum.reindex_bij_betw[OF Rx_bij]) unfolding i k using eq apply auto
    by (smt mult_not_zero sum.neutral)
qed

lemma
  fixes x :: "('a::finite, 'b::finite) lvaluex" and y :: "('a::finite, 'c::finite) lvaluex"
  assumes (* "valid_lvaluex x" and "valid_lvaluex y" and *) "compatible_lvaluex x y"
  assumes domain: "lvaluex_domain x = UNIV"
  assumes range_x: "lvaluex_range x = UNIV"
  assumes range_y: "lvaluex_range y = UNIV"
  defines "xy == compose_lvaluex x y"
  shows "matrix_on A x * matrix_on B y = matrix_on (tensor A B) xy"
  apply (subst matrix_on_lift_left[where A=A and y=y])
  using assms(1-2) apply simp_all[2]
  apply (subst matrix_on_lift_right[where A=B and x=x])
  using assms(1) apply simp_all[3]
  using assms(1,2) domain_compose_lvaluex apply fastforce
  apply (subst matrix_on_times)
   apply (simp add: assms(1) assms(2) assms(3) valid_compose_lvaluex)
  apply (simp add: domain domain_compose_lvaluex(1))
   apply (subst range_compose_lvaluex)
    apply simp
  apply (simp add: range_x range_y)
  unfolding xy_def[symmetric]
  by (simp add: tensor_distrib)

(* ================================= *)

lemma compatible_compose_lvalue_raw0':
  (* assumes "valid_lvalue_raw0 lv1" *)
  (* assumes "valid_lvalue_raw0 lv2" *)
  (* assumes "valid_lvalue_raw0 lv3" *)
  assumes compat: "compatible_lvalue_raw0 lv1 lv2"
  assumes "compatible_lvalue_raw0 lv1 lv3"
  assumes "compatible_lvalue_raw0 lv2 lv3"
  shows "compatible_lvalue_raw0 (lvaluex_lvalue (compose_lvalue_raw0' lv1 lv2)) lv3"

function lvalue_raw_representation0 :: "'a lvalue_raw0 \<Rightarrow> 'a \<Rightarrow> 'a\<times>'a" where
  "lvalue_raw_representation0 (LValueUnit0 D r) x = (r,x)"
| "lvalue_raw_representation0 (LValueAll0 D repr) x = (repr x,undefined)"
| "lvalue_raw_representation0 (LValue0 F lvs rg repr) x =
    (let factors = isomorphism F x;
         factors_repr = \<lambda>i::'a index.
              if i\<in>index_set F then lvalue_raw_representation0 (lvs i) (factors i)
                               else (undefined,undefined);
         factors_result = fst o factors_repr;
         leftover = snd o factors_repr;
         leftover_f = SOME f. inj_on f (dependent_functions (index_set F) (\<lambda>i. lvalue_raw_representation_range0 (lvs i)))
    in
    (repr factors_result, leftover_f leftover))"

definition lvaluex_representation :: "('a,'b) lvaluex \<Rightarrow> 'a \<Rightarrow> 'b\<times>'a" where
  "lvaluex_representation lv x = apfst (lvaluex_fun lv) (lvalue_raw_representation0 (lvaluex_lvalue lv) x)"

definition lvaluex_representation_range :: "('a,'b) lvaluex \<Rightarrow> 'a set" where
  "lvaluex_representation_range lv = lvalue_raw_representation_range0 (lvaluex_lvalue lv)"

definition "lvalue_update0 f lv x = inv (lvalue_raw_representation0 lv)
                                        (apfst f (lvalue_raw_representation0 lv x))"
fun lvaluex_update where
  "lvaluex_update f (LValueX lv g) = lvalue_update0 (inv g o f o g) lv"

definition "left_composition_map f x = (case x of (x,r) \<Rightarrow> case f r of (y,s) \<Rightarrow> ((x,y),s))"
definition "left_composition_map_back f' xy = (case xy of ((x,y),s) \<Rightarrow> (x, f' (y,s)))"

definition "right_composition_map f y = (case y of (y,r) \<Rightarrow> case f r of (x,s) \<Rightarrow> ((x,y),s))"
definition "right_composition_map_back f' xy = (case xy of ((x,y),s) \<Rightarrow> (y, f' (x,s)))"

inductive left_composition_f :: "('a,'b) lvalue \<Rightarrow> ('a,'c) lvalue \<Rightarrow> _" where
"bij_betw f (lvalue_corange x) (lvalue_range y \<times> lvalue_corange (lvalue_compose x y))
  \<Longrightarrow> (\<And>z. left_composition_map f (lvalue_fun x z, lvalue_cofun x z)
              = (lvalue_fun (lvalue_compose x y) z, lvalue_cofun (lvalue_compose x y) z))
  \<Longrightarrow> (f' = inv_into (lvalue_corange x) f)
  \<Longrightarrow> left_composition_f x y f f'"

inductive right_composition_f :: "('a,'b) lvaluex \<Rightarrow> ('a,'c) lvaluex \<Rightarrow> _" where
" (* valid_lvaluex x \<Longrightarrow> valid_lvaluex y \<Longrightarrow> *) compatible_lvaluex x y
  \<Longrightarrow> bij_betw f (lvaluex_representation_range y) (lvaluex_range x \<times> lvaluex_representation_range (compose_lvaluex x y))
  \<Longrightarrow> (\<And>z. right_composition_map f (lvaluex_representation y z) = (lvaluex_representation (compose_lvaluex x y) z))
  \<Longrightarrow> (f' = inv_into (lvaluex_representation_range y) f)
  \<Longrightarrow> right_composition_f x y f f'"

lemma left_composition_f_inv_inj:
  fixes x :: "('a,'b) lvaluex" and y :: "('a,'c) lvaluex"
  assumes left_composition_f: "left_composition_f x y f f'"
  defines "xy == compose_lvaluex x y"
  defines "Rx == lvaluex_representation x"
  defines "Rxy == lvaluex_representation xy"
  assumes z1_dom: "z1 \<in> lvaluex_domain x"
  assumes z2_dom: "z2 \<in> lvaluex_domain x"
  assumes Rxy_z1: "Rxy z1 = ((x1, y1), r1)"
  assumes Rxy_z2: "Rxy z2 = ((x2, y2), r2)"
  shows "f' (y1, r1) = f' (y2, r2) \<longleftrightarrow> (y1,r1) = (y2,r2)"

lemma right_composition_f_inv_inj:
  fixes x :: "('a,'b) lvaluex" and y :: "('a,'c) lvaluex"
  assumes right_composition_f: "right_composition_f x y f f'"
  defines "xy == compose_lvaluex x y"
  defines "Ry == lvaluex_representation y"
  defines "Rxy == lvaluex_representation xy"
  assumes z1_dom: "z1 \<in> lvaluex_domain y"
  assumes z2_dom: "z2 \<in> lvaluex_domain y"
  assumes Rxy_z1: "Rxy z1 = ((x1, y1), r1)"
  assumes Rxy_z2: "Rxy z2 = ((x2, y2), r2)"
  shows "f' (x1, r1) = f' (x2, r2) \<longleftrightarrow> (x1,r1) = (x2,r2)"

lemma left_composition_map_back:
  assumes left_composition_f: "left_composition_f x y f f'"
  defines "xy == compose_lvaluex x y"
  defines "Rx == lvaluex_representation x"
  defines "Rxy == lvaluex_representation xy"
  assumes z: "z \<in> lvaluex_domain x"
  shows "Rx z = left_composition_map_back f' (Rxy z)"

lemma right_composition_map_back:
  assumes right_composition_f: "right_composition_f x y f f'"
  defines "xy == compose_lvaluex x y"
  defines "Ry == lvaluex_representation y"
  defines "Rxy == lvaluex_representation xy"
  assumes z: "z \<in> lvaluex_domain y"
  shows "Ry z = right_composition_map_back f' (Rxy z)"

lemma left_composition_fI:
  fixes f
  assumes compat: "compatible_lvaluex x y"
  defines "f' == inv_into (lvaluex_representation_range x) f"
  assumes bij: "bij_betw f (lvaluex_representation_range x)
     (lvaluex_range y \<times> lvaluex_representation_range (compose_lvaluex x y))"
  assumes map: "\<And>z. left_composition_map f (lvaluex_representation x z)
                          = lvaluex_representation (compose_lvaluex x y) z"
  shows "left_composition_f x y f f'"

lemma composed_lvalue_relationship_left0:
  fixes x y :: "('a,_) lvalue"
  assumes compat: "lvalue_compatible x y"
  shows "\<exists>f.
    bij_betw f (lvalue_raw_representation_range0 x)
               (lvalue_range0 y \<times> lvaluex_representation_range (compose_lvalue_raw0' x y))
  \<and> (\<forall>z. left_composition_map f (lvalue_raw_representation0 x z)
              = (lvaluex_representation (compose_lvalue_raw0' x y) z))"

lemma composed_lvalue_relationship_left:
  fixes x :: "('a,'b) lvalue" and y :: "('a,'c) lvalue"
  assumes compat: "compatible_lvaluex x y"
  obtains f f' where "left_composition_f x y f f'"

lemma composed_lvalue_relationship_right:
  fixes x :: "('a,'b) lvaluex" and y :: "('a,'c) lvaluex"
  (* assumes "valid_lvaluex x" *)
  (* assumes "valid_lvaluex y" *)
  assumes "compatible_lvaluex x y"
  defines "xy == compose_lvaluex x y"
  obtains f f' where "right_composition_f x y f f'"
  sorry

end


(*
    Author:   Salomon Sickert
    License:  BSD
*)

section \<open>Code Export\<close>

theory Normal_Form_Code_Export imports
  LTL.Code_Equations
  LTL.Rewriting
  LTL.Disjunctive_Normal_Form
  HOL.String
  Normal_Form
begin

fun flatten_pi_1_list :: "String.literal ltln \<Rightarrow> String.literal ltln list \<Rightarrow> String.literal ltln"
  where
  "flatten_pi_1_list (\<psi>\<^sub>1 U\<^sub>n \<psi>\<^sub>2) M = (if (\<psi>\<^sub>1 U\<^sub>n \<psi>\<^sub>2) \<in> set M then (flatten_pi_1_list \<psi>\<^sub>1 M) W\<^sub>n (flatten_pi_1_list \<psi>\<^sub>2 M) else false\<^sub>n)"
| "flatten_pi_1_list (\<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2) M = (flatten_pi_1_list \<psi>\<^sub>1 M) W\<^sub>n (flatten_pi_1_list \<psi>\<^sub>2 M)"
| "flatten_pi_1_list (\<psi>\<^sub>1 M\<^sub>n \<psi>\<^sub>2) M = (if (\<psi>\<^sub>1 M\<^sub>n \<psi>\<^sub>2) \<in> set M then (flatten_pi_1_list \<psi>\<^sub>1 M) R\<^sub>n (flatten_pi_1_list \<psi>\<^sub>2 M) else false\<^sub>n)"
| "flatten_pi_1_list (\<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2) M = (flatten_pi_1_list \<psi>\<^sub>1 M) R\<^sub>n (flatten_pi_1_list \<psi>\<^sub>2 M)"
| "flatten_pi_1_list (\<psi>\<^sub>1 and\<^sub>n \<psi>\<^sub>2) M = (flatten_pi_1_list \<psi>\<^sub>1 M) and\<^sub>n (flatten_pi_1_list \<psi>\<^sub>2 M)"
| "flatten_pi_1_list (\<psi>\<^sub>1 or\<^sub>n \<psi>\<^sub>2) M = (flatten_pi_1_list \<psi>\<^sub>1 M) or\<^sub>n (flatten_pi_1_list \<psi>\<^sub>2 M)"
| "flatten_pi_1_list (X\<^sub>n \<psi>) M = X\<^sub>n (flatten_pi_1_list \<psi> M)"
| "flatten_pi_1_list \<phi> _ = \<phi>"

fun flatten_sigma_1_list :: "String.literal ltln \<Rightarrow> String.literal ltln list \<Rightarrow> String.literal ltln"
where
  "flatten_sigma_1_list (\<psi>\<^sub>1 U\<^sub>n \<psi>\<^sub>2) N = (flatten_sigma_1_list \<psi>\<^sub>1 N) U\<^sub>n (flatten_sigma_1_list \<psi>\<^sub>2 N)"
| "flatten_sigma_1_list (\<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2) N = (if (\<psi>\<^sub>1 W\<^sub>n \<psi>\<^sub>2) \<in> set N then true\<^sub>n else (flatten_sigma_1_list \<psi>\<^sub>1 N) U\<^sub>n (flatten_sigma_1_list \<psi>\<^sub>2 N))"
| "flatten_sigma_1_list (\<psi>\<^sub>1 M\<^sub>n \<psi>\<^sub>2) N = (flatten_sigma_1_list \<psi>\<^sub>1 N) M\<^sub>n (flatten_sigma_1_list \<psi>\<^sub>2 N)"
| "flatten_sigma_1_list (\<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2) N = (if (\<psi>\<^sub>1 R\<^sub>n \<psi>\<^sub>2) \<in> set N then true\<^sub>n else (flatten_sigma_1_list \<psi>\<^sub>1 N) M\<^sub>n (flatten_sigma_1_list \<psi>\<^sub>2 N))"
| "flatten_sigma_1_list (\<psi>\<^sub>1 and\<^sub>n \<psi>\<^sub>2) N = (flatten_sigma_1_list \<psi>\<^sub>1 N) and\<^sub>n (flatten_sigma_1_list \<psi>\<^sub>2 N)"
| "flatten_sigma_1_list (\<psi>\<^sub>1 or\<^sub>n \<psi>\<^sub>2) N = (flatten_sigma_1_list \<psi>\<^sub>1 N) or\<^sub>n (flatten_sigma_1_list \<psi>\<^sub>2 N)"
| "flatten_sigma_1_list (X\<^sub>n \<psi>) N = X\<^sub>n (flatten_sigma_1_list \<psi> N)"
| "flatten_sigma_1_list \<phi> _ = \<phi>"

fun flatten_sigma_2_list :: "String.literal ltln \<Rightarrow> String.literal ltln list \<Rightarrow> String.literal ltln"
where
  "flatten_sigma_2_list (\<phi> U\<^sub>n \<psi>) M = (flatten_sigma_2_list \<phi> M) U\<^sub>n (flatten_sigma_2_list \<psi> M)"
| "flatten_sigma_2_list (\<phi> W\<^sub>n \<psi>) M = (flatten_sigma_2_list \<phi> M) U\<^sub>n ((flatten_sigma_2_list \<psi> M) or\<^sub>n (G\<^sub>n (flatten_pi_1_list \<phi> M)))"
| "flatten_sigma_2_list (\<phi> M\<^sub>n \<psi>) M = (flatten_sigma_2_list \<phi> M) M\<^sub>n (flatten_sigma_2_list \<psi> M)"
| "flatten_sigma_2_list (\<phi> R\<^sub>n \<psi>) M = ((flatten_sigma_2_list \<phi> M) or\<^sub>n (G\<^sub>n (flatten_pi_1_list \<psi> M))) M\<^sub>n (flatten_sigma_2_list \<psi> M)"
| "flatten_sigma_2_list (\<phi> and\<^sub>n \<psi>) M = (flatten_sigma_2_list \<phi> M) and\<^sub>n (flatten_sigma_2_list \<psi> M)"
| "flatten_sigma_2_list (\<phi> or\<^sub>n \<psi>) M = (flatten_sigma_2_list \<phi> M) or\<^sub>n (flatten_sigma_2_list \<psi> M)"
| "flatten_sigma_2_list (X\<^sub>n \<phi>) M = X\<^sub>n (flatten_sigma_2_list \<phi> M)"
| "flatten_sigma_2_list \<phi> _ = \<phi>"

lemma flatten_code_equations[simp]:
  "\<phi>[set M]\<^sub>\<Pi>\<^sub>1 = flatten_pi_1_list \<phi> M"
  "\<phi>[set M]\<^sub>\<Sigma>\<^sub>1 = flatten_sigma_1_list \<phi> M"
  "\<phi>[set M]\<^sub>\<Sigma>\<^sub>2 = flatten_sigma_2_list \<phi> M"
  by (induction \<phi>) auto

abbreviation "and_list \<equiv> foldl And_ltln true\<^sub>n"

abbreviation "or_list \<equiv> foldl Or_ltln false\<^sub>n"

definition "normal_form_disjunct (\<phi> :: String.literal ltln) M N
  \<equiv> (flatten_sigma_2_list \<phi> M)
      and\<^sub>n (and_list (map (\<lambda>\<psi>. G\<^sub>n (F\<^sub>n (flatten_sigma_1_list \<psi> N))) M)
      and\<^sub>n (and_list (map (\<lambda>\<psi>. F\<^sub>n (G\<^sub>n (flatten_pi_1_list    \<psi> M))) N)))"

definition "normal_form (\<phi> :: String.literal ltln)
  \<equiv> or_list (map (\<lambda>(M, N). normal_form_disjunct \<phi> M N) (advice_sets \<phi>))"

lemma and_list_semantic: "w \<Turnstile>\<^sub>n and_list xs \<longleftrightarrow> (\<forall>x \<in> set xs. w \<Turnstile>\<^sub>n x)"
  by (induction xs rule: rev_induct) auto

lemma or_list_semantic: "w \<Turnstile>\<^sub>n or_list xs \<longleftrightarrow> (\<exists>x \<in> set xs. w \<Turnstile>\<^sub>n x)"
  by (induction xs rule: rev_induct) auto

theorem normal_form_correct:
  "w \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow> w \<Turnstile>\<^sub>n normal_form \<phi>"
proof
  assume "w \<Turnstile>\<^sub>n \<phi>"
  then obtain M N where "M \<subseteq> subformulas\<^sub>\<mu> \<phi>" and "N \<subseteq> subformulas\<^sub>\<nu> \<phi>"
    and c1: "w \<Turnstile>\<^sub>n \<phi>[M]\<^sub>\<Sigma>\<^sub>2" and c2: "\<forall>\<psi> \<in> M. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>[N]\<^sub>\<Sigma>\<^sub>1)" and c3: "\<forall>\<psi> \<in> N. w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<psi>[M]\<^sub>\<Pi>\<^sub>1)"
    using normal_form_with_flatten_sigma_2 by metis
  then obtain ms ns where "M = set ms" and "N = set ns" and ms_ns_in: "(ms, ns) \<in> set (advice_sets \<phi>)"
    by (meson advice_sets_subformulas)
  then have "w \<Turnstile>\<^sub>n normal_form_disjunct \<phi> ms ns"
    using c1 c2 c3 by (simp add: and_list_semantic normal_form_disjunct_def)
  then show "w \<Turnstile>\<^sub>n normal_form \<phi>"
    using normal_form_def or_list_semantic ms_ns_in by fastforce
next
  assume "w \<Turnstile>\<^sub>n normal_form \<phi>"
  then obtain ms ns where "(ms, ns) \<in> set (advice_sets \<phi>)"
    and "w \<Turnstile>\<^sub>n normal_form_disjunct \<phi> ms ns"
    unfolding normal_form_def or_list_semantic by force
  then have "set ms \<subseteq> subformulas\<^sub>\<mu> \<phi>" and "set ns \<subseteq> subformulas\<^sub>\<nu> \<phi>"
    and c1: "w \<Turnstile>\<^sub>n \<phi>[set ms]\<^sub>\<Sigma>\<^sub>2" and c2: "\<forall>\<psi> \<in> set ms. w \<Turnstile>\<^sub>n G\<^sub>n (F\<^sub>n \<psi>[set ns]\<^sub>\<Sigma>\<^sub>1)" and c3: "\<forall>\<psi> \<in> set ns. w \<Turnstile>\<^sub>n F\<^sub>n (G\<^sub>n \<psi>[set ms]\<^sub>\<Pi>\<^sub>1)"
    using advice_sets_element_subfrmlsn
    by (auto simp: and_list_semantic normal_form_disjunct_def) blast
  then show "w \<Turnstile>\<^sub>n \<phi>"
    using normal_form_with_flatten_sigma_2 by metis
qed

definition "normal_form_with_simplifier (\<phi> :: String.literal ltln)
  \<equiv> min_dnf (simplify Slow (normal_form (simplify Slow \<phi>)))"

lemma ltl_semantics_min_dnf:
  "w \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow> (\<exists>C \<in> min_dnf \<phi>. \<forall>\<psi>. \<psi> |\<in>| C \<longrightarrow> w \<Turnstile>\<^sub>n \<psi>)" (is "?lhs \<longleftrightarrow> ?rhs")
proof
  let ?M = "{\<psi>. w \<Turnstile>\<^sub>n \<psi>}"
  assume ?lhs
  hence "?M \<Turnstile>\<^sub>P \<phi>"
    using ltl_models_equiv_prop_entailment by blast
  then obtain M' where "fset M' \<subseteq> ?M" and "M' \<in> min_dnf \<phi>"
    using min_dnf_iff_prop_assignment_subset by blast
  thus ?rhs
    by (meson in_mono mem_Collect_eq notin_fset)
next
  let ?M = "{\<psi>. w \<Turnstile>\<^sub>n \<psi>}"
  assume ?rhs
  then obtain M' where "fset M' \<subseteq> ?M" and "M' \<in> min_dnf \<phi>"
    using notin_fset by fastforce
  hence "?M \<Turnstile>\<^sub>P \<phi>"
    using min_dnf_iff_prop_assignment_subset by blast
  thus ?lhs
    using ltl_models_equiv_prop_entailment by blast
qed

theorem
  "w \<Turnstile>\<^sub>n \<phi> \<longleftrightarrow> (\<exists>C \<in> (normal_form_with_simplifier \<phi>). \<forall>\<psi>. \<psi> |\<in>| C \<longrightarrow> w \<Turnstile>\<^sub>n \<psi>)" (is "?lhs \<longleftrightarrow> ?rhs")
  unfolding normal_form_with_simplifier_def ltl_semantics_min_dnf[symmetric]
  using normal_form_correct by simp

text \<open>In order to export the code run \texttt{isabelle build -D [PATH] -e}.\<close>

export_code normal_form in SML
export_code normal_form_with_simplifier in SML

end