section \<open> Alphabetised Predicates \<close>

theory utp_pred
imports
  utp_expr_funcs
  utp_subst
  utp_meta_subst
  utp_tactics
begin

text \<open> In this theory we begin to create an Isabelle version of the alphabetised predicate calculus
  that is described in Chapter 1 of the UTP book~\<^cite>\<open>"Hoare&98"\<close>. \<close>

subsection \<open> Predicate type and syntax \<close>

text \<open> An alphabetised predicate is a simply a boolean valued expression. \<close>

type_synonym '\<alpha> upred = "(bool, '\<alpha>) uexpr"

translations
  (type) "'\<alpha> upred" <= (type) "(bool, '\<alpha>) uexpr"

text \<open> We want to remain as close as possible to the mathematical UTP syntax, but also
        want to be conservative with HOL. For this reason we chose not to steal syntax
        from HOL, but where possible use polymorphism to allow selection of the appropriate
        operator (UTP vs. HOL). Thus we will first remove the standard syntax for conjunction,
        disjunction, and negation, and replace these with adhoc overloaded definitions. We
        similarly use polymorphic constants for the other predicate calculus operators. \<close>

purge_notation
  conj (infixr "\<and>" 35) and
  disj (infixr "\<or>" 30) and
  Not ("\<not> _" [40] 40)

consts
  utrue  :: "'a" ("true")
  ufalse :: "'a" ("false")
  uconj  :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<and>" 35)
  udisj  :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<or>" 30)
  uimpl  :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<Rightarrow>" 25)
  uiff   :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<Leftrightarrow>" 25)
  unot   :: "'a \<Rightarrow> 'a" ("\<not> _" [40] 40)
  uex    :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> 'p \<Rightarrow> 'p"
  uall   :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> 'p \<Rightarrow> 'p"
  ushEx  :: "['a \<Rightarrow> 'p] \<Rightarrow> 'p"
  ushAll :: "['a \<Rightarrow> 'p] \<Rightarrow> 'p"

adhoc_overloading
  uconj conj and
  udisj disj and
  unot Not

text \<open> We set up two versions of each of the quantifiers: @{const uex} / @{const uall} and
        @{const ushEx} / @{const ushAll}. The former pair allows quantification of UTP variables,
        whilst the latter allows quantification of HOL variables in concert with the literal
        expression constructor @{term "\<guillemotleft>x\<guillemotright>"}. Both varieties will be needed at various points.
        Syntactically they are distinguished by a boldface quantifier
        for the HOL versions (achieved by the "bold" escape in Isabelle). \<close>

nonterminal idt_list

syntax
  "_idt_el"  :: "idt \<Rightarrow> idt_list" ("_")
  "_idt_list" :: "idt \<Rightarrow> idt_list \<Rightarrow> idt_list" ("(_,/ _)" [0, 1])
  "_uex"     :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("\<exists> _ \<bullet> _" [0, 10] 10)
  "_uall"    :: "salpha \<Rightarrow> logic \<Rightarrow> logic" ("\<forall> _ \<bullet> _" [0, 10] 10)
  "_ushEx"   :: "pttrn \<Rightarrow> logic \<Rightarrow> logic"   ("\<^bold>\<exists> _ \<bullet> _" [0, 10] 10)
  "_ushAll"  :: "pttrn \<Rightarrow> logic \<Rightarrow> logic"   ("\<^bold>\<forall> _ \<bullet> _" [0, 10] 10)
  "_ushBEx"  :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<^bold>\<exists> _ \<in> _ \<bullet> _" [0, 0, 10] 10)
  "_ushBAll" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<^bold>\<forall> _ \<in> _ \<bullet> _" [0, 0, 10] 10)
  "_ushGAll" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<^bold>\<forall> _ | _ \<bullet> _" [0, 0, 10] 10)
  "_ushGtAll" :: "idt \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("\<^bold>\<forall> _ > _ \<bullet> _" [0, 0, 10] 10)
  "_ushLtAll" :: "idt \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic" ("\<^bold>\<forall> _ < _ \<bullet> _" [0, 0, 10] 10)
  "_uvar_res" :: "logic \<Rightarrow> salpha \<Rightarrow> logic" (infixl "\<restriction>\<^sub>v" 90)

translations
  "_uex x P"                   == "CONST uex x P"
  "_uex (_salphaset (_salphamk (x +\<^sub>L y))) P"  <= "_uex (x +\<^sub>L y) P"
  "_uall x P"                  == "CONST uall x P"
  "_uall (_salphaset (_salphamk (x +\<^sub>L y))) P"  <= "_uall (x +\<^sub>L y) P"
  "_ushEx x P"                 == "CONST ushEx (\<lambda> x. P)"
  "\<^bold>\<exists> x \<in> A \<bullet> P"                => "\<^bold>\<exists> x \<bullet> \<guillemotleft>x\<guillemotright> \<in>\<^sub>u A \<and> P"
  "_ushAll x P"                == "CONST ushAll (\<lambda> x. P)"
  "\<^bold>\<forall> x \<in> A \<bullet> P"                => "\<^bold>\<forall> x \<bullet> \<guillemotleft>x\<guillemotright> \<in>\<^sub>u A \<Rightarrow> P"
  "\<^bold>\<forall> x | P \<bullet> Q"                => "\<^bold>\<forall> x \<bullet> P \<Rightarrow> Q"
  "\<^bold>\<forall> x > y \<bullet> P"                => "\<^bold>\<forall> x \<bullet> \<guillemotleft>x\<guillemotright> >\<^sub>u y \<Rightarrow> P"
  "\<^bold>\<forall> x < y \<bullet> P"                => "\<^bold>\<forall> x \<bullet> \<guillemotleft>x\<guillemotright> <\<^sub>u y \<Rightarrow> P"

subsection \<open> Predicate operators \<close>

text \<open> We chose to maximally reuse definitions and laws built into HOL. For this reason,
        when introducing the core operators we proceed by lifting operators from the
        polymorphic algebraic hierarchy of HOL. Thus the initial definitions take
        place in the context of type class instantiations. We first introduce our own
        class called \emph{refine} that will add the refinement operator syntax to
        the HOL partial order class. \<close>

class refine = order

abbreviation refineBy :: "'a::refine \<Rightarrow> 'a \<Rightarrow> bool"  (infix "\<sqsubseteq>" 50) where
"P \<sqsubseteq> Q \<equiv> less_eq Q P"

text \<open> Since, on the whole, lattices in UTP are the opposite way up to the standard definitions
        in HOL, we syntactically invert the lattice operators. This is the one exception where
        we do steal HOL syntax, but I think it makes sense for UTP. Indeed we make this
        inversion for all of the lattice operators. \<close>

purge_notation Lattices.inf (infixl "\<sqinter>" 70)
notation Lattices.inf (infixl "\<squnion>" 70)
purge_notation Lattices.sup (infixl "\<squnion>" 65)
notation Lattices.sup (infixl "\<sqinter>" 65)

purge_notation Inf ("\<Sqinter>_" [900] 900)
notation Inf ("\<Squnion>_" [900] 900)
purge_notation Sup ("\<Squnion>_" [900] 900)
notation Sup ("\<Sqinter>_" [900] 900)

purge_notation Orderings.bot ("\<bottom>")
notation Orderings.bot ("\<top>")
purge_notation Orderings.top ("\<top>")
notation Orderings.top ("\<bottom>")

purge_syntax
  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)
  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)

syntax
  "_INF1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Squnion>_./ _)" [0, 10] 10)
  "_INF"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Squnion>_\<in>_./ _)" [0, 0, 10] 10)
  "_SUP1"     :: "pttrns \<Rightarrow> 'b \<Rightarrow> 'b"           ("(3\<Sqinter>_./ _)" [0, 10] 10)
  "_SUP"      :: "pttrn \<Rightarrow> 'a set \<Rightarrow> 'b \<Rightarrow> 'b"  ("(3\<Sqinter>_\<in>_./ _)" [0, 0, 10] 10)

text \<open> We trivially instantiate our refinement class \<close>

instance uexpr :: (order, type) refine ..

\<comment> \<open> Configure transfer law for refinement for the fast relational tactics. \<close>

theorem upred_ref_iff [uexpr_transfer_laws]:
"(P \<sqsubseteq> Q) = (\<forall>b. \<lbrakk>Q\<rbrakk>\<^sub>e b \<longrightarrow> \<lbrakk>P\<rbrakk>\<^sub>e b)"
  apply (transfer)
  apply (clarsimp)
  done

text \<open> Next we introduce the lattice operators, which is again done by lifting. \<close>

instantiation uexpr :: (lattice, type) lattice
begin
  lift_definition sup_uexpr :: "('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr"
  is "\<lambda>P Q A. Lattices.sup (P A) (Q A)" .
  lift_definition inf_uexpr :: "('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr \<Rightarrow> ('a, 'b) uexpr"
  is "\<lambda>P Q A. Lattices.inf (P A) (Q A)" .
instance
  by (intro_classes) (transfer, auto)+
end

instantiation uexpr :: (bounded_lattice, type) bounded_lattice
begin
  lift_definition bot_uexpr :: "('a, 'b) uexpr" is "\<lambda> A. Orderings.bot" .
  lift_definition top_uexpr :: "('a, 'b) uexpr" is "\<lambda> A. Orderings.top" .
instance
  by (intro_classes) (transfer, auto)+
end

lemma top_uexpr_rep_eq [simp]:
  "\<lbrakk>Orderings.bot\<rbrakk>\<^sub>e b = False"
  by (transfer, auto)

lemma bot_uexpr_rep_eq [simp]:
  "\<lbrakk>Orderings.top\<rbrakk>\<^sub>e b = True"
  by (transfer, auto)

instance uexpr :: (distrib_lattice, type) distrib_lattice
  by (intro_classes) (transfer, rule ext, auto simp add: sup_inf_distrib1)

text \<open> Finally we show that predicates form a Boolean algebra (under the lattice operators),
  a complete lattice, a completely distribute lattice, and a complete boolean algebra. This
  equip us with a very complete theory for basic logical propositions. \<close>

instance uexpr :: (boolean_algebra, type) boolean_algebra
  apply (intro_classes, unfold uexpr_defs; transfer, rule ext)
    apply (simp_all add: sup_inf_distrib1 diff_eq)
  done

instantiation uexpr :: (complete_lattice, type) complete_lattice
begin
  lift_definition Inf_uexpr :: "('a, 'b) uexpr set \<Rightarrow> ('a, 'b) uexpr"
  is "\<lambda> PS A. INF P\<in>PS. P(A)" .
  lift_definition Sup_uexpr :: "('a, 'b) uexpr set \<Rightarrow> ('a, 'b) uexpr"
  is "\<lambda> PS A. SUP P\<in>PS. P(A)" .
instance
  by (intro_classes)
     (transfer, auto intro: INF_lower SUP_upper simp add: INF_greatest SUP_least)+
end

instance uexpr :: (complete_distrib_lattice, type) complete_distrib_lattice
  by (intro_classes; transfer; auto simp add: INF_SUP_set)

instance uexpr :: (complete_boolean_algebra, type) complete_boolean_algebra ..

text \<open> From the complete lattice, we can also define and give syntax for the fixed-point operators.
  Like the lattice operators, these are reversed in UTP. \<close>

syntax
  "_mu" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic" ("\<mu> _ \<bullet> _" [0, 10] 10)
  "_nu" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic" ("\<nu> _ \<bullet> _" [0, 10] 10)

notation gfp ("\<mu>")
notation lfp ("\<nu>")

translations
  "\<nu> X \<bullet> P" == "CONST lfp (\<lambda> X. P)"
  "\<mu> X \<bullet> P" == "CONST gfp (\<lambda> X. P)"

text \<open> With the lattice operators defined, we can proceed to give definitions for the
        standard predicate operators in terms of them. \<close>

definition "true_upred  = (Orderings.top :: '\<alpha> upred)"
definition "false_upred = (Orderings.bot :: '\<alpha> upred)"
definition "conj_upred  = (Lattices.inf :: '\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred)"
definition "disj_upred  = (Lattices.sup :: '\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred)"
definition "not_upred   = (uminus :: '\<alpha> upred \<Rightarrow> '\<alpha> upred)"
definition "diff_upred  = (minus :: '\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred)"

abbreviation Conj_upred :: "'\<alpha> upred set \<Rightarrow> '\<alpha> upred" ("\<And>_" [900] 900) where
"\<And> A \<equiv> \<Squnion> A"

abbreviation Disj_upred :: "'\<alpha> upred set \<Rightarrow> '\<alpha> upred" ("\<Or>_" [900] 900) where
"\<Or> A \<equiv> \<Sqinter> A"

notation
  conj_upred (infixr "\<and>\<^sub>p" 35) and
  disj_upred (infixr "\<or>\<^sub>p" 30)

text \<open> Perhaps slightly confusingly, the UTP infimum is the HOL supremum and vice-versa. This is
  because, again, in UTP the lattice is inverted due to the definition of refinement and a desire
  to have miracle at the top, and abort at the bottom. \<close>

lift_definition UINF :: "('a \<Rightarrow> '\<alpha> upred) \<Rightarrow> ('a \<Rightarrow> ('b::complete_lattice, '\<alpha>) uexpr) \<Rightarrow> ('b, '\<alpha>) uexpr"
is "\<lambda> P F b. Sup {\<lbrakk>F x\<rbrakk>\<^sub>eb | x. \<lbrakk>P x\<rbrakk>\<^sub>eb}" .

lift_definition USUP :: "('a \<Rightarrow> '\<alpha> upred) \<Rightarrow> ('a \<Rightarrow> ('b::complete_lattice, '\<alpha>) uexpr) \<Rightarrow> ('b, '\<alpha>) uexpr"
is "\<lambda> P F b. Inf {\<lbrakk>F x\<rbrakk>\<^sub>eb | x. \<lbrakk>P x\<rbrakk>\<^sub>eb}" .

syntax
  "_USup"     :: "pttrn \<Rightarrow> logic \<Rightarrow> logic"            ("\<And> _ \<bullet> _" [0, 10] 10)
  "_USup"     :: "pttrn \<Rightarrow> logic \<Rightarrow> logic"            ("\<Squnion> _ \<bullet> _" [0, 10] 10)
  "_USup_mem" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<And> _ \<in> _ \<bullet> _" [0, 10] 10)
  "_USup_mem" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<Squnion> _ \<in> _ \<bullet> _" [0, 10] 10)
  "_USUP"     :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<And> _ | _ \<bullet> _" [0, 0, 10] 10)
  "_USUP"     :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<Squnion> _ | _ \<bullet> _" [0, 0, 10] 10)
  "_UInf"     :: "pttrn \<Rightarrow> logic \<Rightarrow> logic"            ("\<Or> _ \<bullet> _" [0, 10] 10)
  "_UInf"     :: "pttrn \<Rightarrow> logic \<Rightarrow> logic"            ("\<Sqinter> _ \<bullet> _" [0, 10] 10)
  "_UInf_mem" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<Or> _ \<in> _ \<bullet> _" [0, 10] 10)
  "_UInf_mem" :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<Sqinter> _ \<in> _ \<bullet> _" [0, 10] 10)
  "_UINF"     :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<Or> _ | _ \<bullet> _" [0, 10] 10)
  "_UINF"     :: "pttrn \<Rightarrow> logic \<Rightarrow> logic \<Rightarrow> logic"   ("\<Sqinter> _ | _ \<bullet> _" [0, 10] 10)

translations
  "\<Sqinter> x | P \<bullet> F" => "CONST UINF (\<lambda> x. P) (\<lambda> x. F)"
  "\<Sqinter> x \<bullet> F"     == "\<Sqinter> x | true \<bullet> F"
  "\<Sqinter> x \<bullet> F"     == "\<Sqinter> x | true \<bullet> F"
  "\<Sqinter> x \<in> A \<bullet> F" => "\<Sqinter> x | \<guillemotleft>x\<guillemotright> \<in>\<^sub>u \<guillemotleft>A\<guillemotright> \<bullet> F"
  "\<Sqinter> x \<in> A \<bullet> F" <= "\<Sqinter> x | \<guillemotleft>y\<guillemotright> \<in>\<^sub>u \<guillemotleft>A\<guillemotright> \<bullet> F"
  "\<Sqinter> x | P \<bullet> F" <= "CONST UINF (\<lambda> y. P) (\<lambda> x. F)"
  "\<Sqinter> x | P \<bullet> F(x)" <= "CONST UINF (\<lambda> x. P) F"
  "\<Squnion> x | P \<bullet> F" => "CONST USUP (\<lambda> x. P) (\<lambda> x. F)"
  "\<Squnion> x \<bullet> F"     == "\<Squnion> x | true \<bullet> F"
  "\<Squnion> x \<in> A \<bullet> F" => "\<Squnion> x | \<guillemotleft>x\<guillemotright> \<in>\<^sub>u \<guillemotleft>A\<guillemotright> \<bullet> F"
  "\<Squnion> x \<in> A \<bullet> F" <= "\<Squnion> x | \<guillemotleft>y\<guillemotright> \<in>\<^sub>u \<guillemotleft>A\<guillemotright> \<bullet> F"
  "\<Squnion> x | P \<bullet> F" <= "CONST USUP (\<lambda> y. P) (\<lambda> x. F)"
  "\<Squnion> x | P \<bullet> F(x)" <= "CONST USUP (\<lambda> x. P) F"

text \<open> We also define the other predicate operators \<close>

lift_definition impl::"'\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred" is
"\<lambda> P Q A. P A \<longrightarrow> Q A" .

lift_definition iff_upred ::"'\<alpha> upred \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred" is
"\<lambda> P Q A. P A \<longleftrightarrow> Q A" .

lift_definition ex :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred" is
"\<lambda> x P b. (\<exists> v. P(put\<^bsub>x\<^esub> b v))" .

lift_definition shEx ::"['\<beta> \<Rightarrow>'\<alpha> upred] \<Rightarrow> '\<alpha> upred" is
"\<lambda> P A. \<exists> x. (P x) A" .

lift_definition all :: "('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> upred \<Rightarrow> '\<alpha> upred" is
"\<lambda> x P b. (\<forall> v. P(put\<^bsub>x\<^esub> b v))" .

lift_definition shAll ::"['\<beta> \<Rightarrow>'\<alpha> upred] \<Rightarrow> '\<alpha> upred" is
"\<lambda> P A. \<forall> x. (P x) A" .

text \<open> We define the following operator which is dual of existential quantification. It hides the
  valuation of variables other than $x$ through existential quantification. \<close>

lift_definition var_res :: "'\<alpha> upred \<Rightarrow> ('a \<Longrightarrow> '\<alpha>) \<Rightarrow> '\<alpha> upred" is
"\<lambda> P x b. \<exists> b'. P (b' \<oplus>\<^sub>L b on x)" .

translations
  "_uvar_res P a" \<rightleftharpoons> "CONST var_res P a"

text \<open> We have to add a u subscript to the closure operator as I don't want to override the syntax
        for HOL lists (we'll be using them later). \<close>

lift_definition closure::"'\<alpha> upred \<Rightarrow> '\<alpha> upred" ("[_]\<^sub>u") is
"\<lambda> P A. \<forall>A'. P A'" .

lift_definition taut :: "'\<alpha> upred \<Rightarrow> bool" ("`_`")
is "\<lambda> P. \<forall> A. P A" .

text \<open> Configuration for UTP tactics \<close>

update_uexpr_rep_eq_thms \<comment> \<open> Reread @{text rep_eq} theorems. \<close>

declare utp_pred.taut.rep_eq [upred_defs]

adhoc_overloading
  utrue "true_upred" and
  ufalse "false_upred" and
  unot "not_upred" and
  uconj "conj_upred" and
  udisj "disj_upred" and
  uimpl impl and
  uiff iff_upred and
  uex ex and
  uall all and
  ushEx shEx and
  ushAll shAll

syntax
  "_uneq"       :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infixl "\<noteq>\<^sub>u" 50)
  "_unmem"      :: "('a, '\<alpha>) uexpr \<Rightarrow> ('a set, '\<alpha>) uexpr \<Rightarrow> (bool, '\<alpha>) uexpr" (infix "\<notin>\<^sub>u" 50)

translations
  "x \<noteq>\<^sub>u y" == "CONST unot (x =\<^sub>u y)"
  "x \<notin>\<^sub>u A" == "CONST unot (CONST bop (\<in>) x A)"

declare true_upred_def [upred_defs]
declare false_upred_def [upred_defs]
declare conj_upred_def [upred_defs]
declare disj_upred_def [upred_defs]
declare not_upred_def [upred_defs]
declare diff_upred_def [upred_defs]
declare subst_upd_uvar_def [upred_defs]
declare cond_subst_def [upred_defs]
declare par_subst_def [upred_defs]
declare subst_del_def [upred_defs]
declare unrest_usubst_def [upred_defs]
declare uexpr_defs [upred_defs]

lemma true_alt_def: "true = \<guillemotleft>True\<guillemotright>"
  by (pred_auto)

declare true_alt_def[THEN sym,simp]
declare false_alt_def[THEN sym,simp]

subsection \<open> Unrestriction Laws \<close>

lemma unrest_allE:
  "\<lbrakk> \<Sigma> \<sharp> P; P = true \<Longrightarrow> Q; P = false \<Longrightarrow> Q \<rbrakk> \<Longrightarrow> Q"
  by (pred_auto)

lemma unrest_true [unrest]: "x \<sharp> true"
  by (pred_auto)

lemma unrest_false [unrest]: "x \<sharp> false"
  by (pred_auto)

lemma unrest_conj [unrest]: "\<lbrakk> x \<sharp> (P :: '\<alpha> upred); x \<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp> P \<and> Q"
  by (pred_auto)

lemma unrest_disj [unrest]: "\<lbrakk> x \<sharp> (P :: '\<alpha> upred); x \<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp> P \<or> Q"
  by (pred_auto)

lemma unrest_UINF [unrest]:
  "\<lbrakk> (\<And> i. x \<sharp> P(i)); (\<And> i. x \<sharp> Q(i)) \<rbrakk> \<Longrightarrow> x \<sharp> (\<Sqinter> i | P(i) \<bullet> Q(i))"
  by (pred_auto)

lemma unrest_USUP [unrest]:
  "\<lbrakk> (\<And> i. x \<sharp> P(i)); (\<And> i. x \<sharp> Q(i)) \<rbrakk> \<Longrightarrow> x \<sharp> (\<Squnion> i | P(i) \<bullet> Q(i))"
  by (pred_auto)

lemma unrest_UINF_mem [unrest]:
  "\<lbrakk>(\<And> i. i \<in> A \<Longrightarrow> x \<sharp> P(i)) \<rbrakk> \<Longrightarrow> x \<sharp> (\<Sqinter> i\<in>A \<bullet> P(i))"
  by (pred_simp, metis)

lemma unrest_USUP_mem [unrest]:
  "\<lbrakk>(\<And> i. i \<in> A \<Longrightarrow> x \<sharp> P(i)) \<rbrakk> \<Longrightarrow> x \<sharp> (\<Squnion> i\<in>A \<bullet> P(i))"
  by (pred_simp, metis)

lemma unrest_impl [unrest]: "\<lbrakk> x \<sharp> P; x \<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp> P \<Rightarrow> Q"
  by (pred_auto)

lemma unrest_iff [unrest]: "\<lbrakk> x \<sharp> P; x \<sharp> Q \<rbrakk> \<Longrightarrow> x \<sharp> P \<Leftrightarrow> Q"
  by (pred_auto)

lemma unrest_not [unrest]: "x \<sharp> (P :: '\<alpha> upred) \<Longrightarrow> x \<sharp> (\<not> P)"
  by (pred_auto)

text \<open> The sublens proviso can be thought of as membership below. \<close>

lemma unrest_ex_in [unrest]:
  "\<lbrakk> mwb_lens y; x \<subseteq>\<^sub>L y \<rbrakk> \<Longrightarrow> x \<sharp> (\<exists> y \<bullet> P)"
  by (pred_auto)

declare sublens_refl [simp]
declare lens_plus_ub [simp]
declare lens_plus_right_sublens [simp]
declare comp_wb_lens [simp]
declare comp_mwb_lens [simp]
declare plus_mwb_lens [simp]

lemma unrest_ex_diff [unrest]:
  assumes "x \<bowtie> y" "y \<sharp> P"
  shows "y \<sharp> (\<exists> x \<bullet> P)"
  using assms lens_indep_comm
  by (rel_simp', fastforce)

lemma unrest_all_in [unrest]:
  "\<lbrakk> mwb_lens y; x \<subseteq>\<^sub>L y \<rbrakk> \<Longrightarrow> x \<sharp> (\<forall> y \<bullet> P)"
  by (pred_auto)

lemma unrest_all_diff [unrest]:
  assumes "x \<bowtie> y" "y \<sharp> P"
  shows "y \<sharp> (\<forall> x \<bullet> P)"
  using assms
  by (pred_simp, simp_all add: lens_indep_comm)

lemma unrest_var_res_diff [unrest]:
  assumes "x \<bowtie> y"
  shows "y \<sharp> (P \<restriction>\<^sub>v x)"
  using assms by (pred_auto)

lemma unrest_var_res_in [unrest]:
  assumes "mwb_lens x" "y \<subseteq>\<^sub>L x" "y \<sharp> P"
  shows "y \<sharp> (P \<restriction>\<^sub>v x)"
  using assms
  apply (pred_auto)
   apply fastforce
  apply (metis (no_types, lifting) mwb_lens_weak weak_lens.put_get)
  done

lemma unrest_shEx [unrest]:
  assumes "\<And> y. x \<sharp> P(y)"
  shows "x \<sharp> (\<^bold>\<exists> y \<bullet> P(y))"
  using assms by (pred_auto)

lemma unrest_shAll [unrest]:
  assumes "\<And> y. x \<sharp> P(y)"
  shows "x \<sharp> (\<^bold>\<forall> y \<bullet> P(y))"
  using assms by (pred_auto)

lemma unrest_closure [unrest]:
  "x \<sharp> [P]\<^sub>u"
  by (pred_auto)

subsection \<open> Used-by laws \<close>

lemma usedBy_not [unrest]:
  "\<lbrakk> x \<natural> P \<rbrakk> \<Longrightarrow> x \<natural> (\<not> P)"
  by (pred_simp)

lemma usedBy_conj [unrest]:
  "\<lbrakk> x \<natural> P; x \<natural> Q \<rbrakk> \<Longrightarrow> x \<natural> (P \<and> Q)"
  by (pred_simp)

lemma usedBy_disj [unrest]:
  "\<lbrakk> x \<natural> P; x \<natural> Q \<rbrakk> \<Longrightarrow> x \<natural> (P \<or> Q)"
  by (pred_simp)

lemma usedBy_impl [unrest]:
  "\<lbrakk> x \<natural> P; x \<natural> Q \<rbrakk> \<Longrightarrow> x \<natural> (P \<Rightarrow> Q)"
  by (pred_simp)

lemma usedBy_iff [unrest]:
  "\<lbrakk> x \<natural> P; x \<natural> Q \<rbrakk> \<Longrightarrow> x \<natural> (P \<Leftrightarrow> Q)"
  by (pred_simp)

subsection \<open> Substitution Laws \<close>

text \<open> Substitution is monotone \<close>

lemma subst_mono: "P \<sqsubseteq> Q \<Longrightarrow> (\<sigma> \<dagger> P) \<sqsubseteq> (\<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_true [usubst]: "\<sigma> \<dagger> true = true"
  by (pred_auto)

lemma subst_not [usubst]: "\<sigma> \<dagger> (\<not> P) = (\<not> \<sigma> \<dagger> P)"
  by (pred_auto)

lemma subst_impl [usubst]: "\<sigma> \<dagger> (P \<Rightarrow> Q) = (\<sigma> \<dagger> P \<Rightarrow> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_iff [usubst]: "\<sigma> \<dagger> (P \<Leftrightarrow> Q) = (\<sigma> \<dagger> P \<Leftrightarrow> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_disj [usubst]: "\<sigma> \<dagger> (P \<or> Q) = (\<sigma> \<dagger> P \<or> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_conj [usubst]: "\<sigma> \<dagger> (P \<and> Q) = (\<sigma> \<dagger> P \<and> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_sup [usubst]: "\<sigma> \<dagger> (P \<sqinter> Q) = (\<sigma> \<dagger> P \<sqinter> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_inf [usubst]: "\<sigma> \<dagger> (P \<squnion> Q) = (\<sigma> \<dagger> P \<squnion> \<sigma> \<dagger> Q)"
  by (pred_auto)

lemma subst_UINF [usubst]: "\<sigma> \<dagger> (\<Sqinter> i | P(i) \<bullet> Q(i)) = (\<Sqinter> i | (\<sigma> \<dagger> P(i)) \<bullet> (\<sigma> \<dagger> Q(i)))"
  by (pred_auto)

lemma subst_USUP [usubst]: "\<sigma> \<dagger> (\<Squnion> i | P(i) \<bullet> Q(i)) = (\<Squnion> i | (\<sigma> \<dagger> P(i)) \<bullet> (\<sigma> \<dagger> Q(i)))"
  by (pred_auto)

lemma subst_closure [usubst]: "\<sigma> \<dagger> [P]\<^sub>u = [P]\<^sub>u"
  by (pred_auto)

lemma subst_shEx [usubst]: "\<sigma> \<dagger> (\<^bold>\<exists> x \<bullet> P(x)) = (\<^bold>\<exists> x \<bullet> \<sigma> \<dagger> P(x))"
  by (pred_auto)

lemma subst_shAll [usubst]: "\<sigma> \<dagger> (\<^bold>\<forall> x \<bullet> P(x)) = (\<^bold>\<forall> x \<bullet> \<sigma> \<dagger> P(x))"
  by (pred_auto)

text \<open> TODO: Generalise the quantifier substitution laws to n-ary substitutions \<close>

lemma subst_ex_same [usubst]:
  "mwb_lens x \<Longrightarrow> \<sigma>(x \<mapsto>\<^sub>s v) \<dagger> (\<exists> x \<bullet> P) = \<sigma> \<dagger> (\<exists> x \<bullet> P)"
  by (pred_auto)

lemma subst_ex_same' [usubst]:
  "mwb_lens x \<Longrightarrow> \<sigma>(x \<mapsto>\<^sub>s v) \<dagger> (\<exists> &x \<bullet> P) = \<sigma> \<dagger> (\<exists> &x \<bullet> P)"
  by (pred_auto)

lemma subst_ex_indep [usubst]:
  assumes "x \<bowtie> y" "y \<sharp> v"
  shows "(\<exists> y \<bullet> P)\<lbrakk>v/x\<rbrakk> = (\<exists> y \<bullet> P\<lbrakk>v/x\<rbrakk>)"
  using assms
  apply (pred_auto)
  using lens_indep_comm apply fastforce+
  done

lemma subst_ex_unrest [usubst]:
  "x \<sharp> \<sigma> \<Longrightarrow> \<sigma> \<dagger> (\<exists> x \<bullet> P) = (\<exists> x \<bullet> \<sigma> \<dagger> P)"
  by (pred_auto)

lemma subst_all_same [usubst]:
  "mwb_lens x \<Longrightarrow> \<sigma>(x \<mapsto>\<^sub>s v) \<dagger> (\<forall> x \<bullet> P) = \<sigma> \<dagger> (\<forall> x \<bullet> P)"
  by (simp add: id_subst subst_unrest unrest_all_in)

lemma subst_all_indep [usubst]:
  assumes "x \<bowtie> y" "y \<sharp> v"
  shows "(\<forall> y \<bullet> P)\<lbrakk>v/x\<rbrakk> = (\<forall> y \<bullet> P\<lbrakk>v/x\<rbrakk>)"
  using assms
  by (pred_simp, simp_all add: lens_indep_comm)

lemma msubst_true [usubst]: "true\<lbrakk>x\<rightarrow>v\<rbrakk> = true"
  by (pred_auto)

lemma msubst_false [usubst]: "false\<lbrakk>x\<rightarrow>v\<rbrakk> = false"
  by (pred_auto)
lemma msubst_not [usubst]: "(\<not> P(x))\<lbrakk>x\<rightarrow>v\<rbrakk> = (\<not> ((P x)\<lbrakk>x\<rightarrow>v\<rbrakk>))"
  by (pred_auto)

lemma msubst_not_2 [usubst]: "(\<not> P x y)\<lbrakk>(x,y)\<rightarrow>v\<rbrakk> = (\<not> ((P x y)\<lbrakk>(x,y)\<rightarrow>v\<rbrakk>))"
  by (pred_auto)+

lemma msubst_disj [usubst]: "(P(x) \<or> Q(x))\<lbrakk>x\<rightarrow>v\<rbrakk> = ((P(x))\<lbrakk>x\<rightarrow>v\<rbrakk> \<or> (Q(x))\<lbrakk>x\<rightarrow>v\<rbrakk>)"
  by (pred_auto)

lemma msubst_disj_2 [usubst]: "(P x y \<or> Q x y)\<lbrakk>(x,y)\<rightarrow>v\<rbrakk> = ((P x y)\<lbrakk>(x,y)\<rightarrow>v\<rbrakk> \<or> (Q x y)\<lbrakk>(x,y)\<rightarrow>v\<rbrakk>)"
  by (pred_auto)+

lemma msubst_conj [usubst]: "(P(x) \<and> Q(x))\<lbrakk>x\<rightarrow>v\<rbrakk> = ((P(x))\<lbrakk>x\<rightarrow>v\<rbrakk> \<and> (Q(x))\<lbrakk>x\<rightarrow>v\<rbrakk>)"
  by (pred_auto)

lemma msubst_conj_2 [usubst]: "(P x y \<and> Q x y)\<lbrakk>(x,y)\<rightarrow>v\<rbrakk> = ((P x y)\<lbrakk>(x,y)\<rightarrow>v\<rbrakk> \<and> (Q x y)\<lbrakk>(x,y)\<rightarrow>v\<rbrakk>)"
  by (pred_auto)+

lemma msubst_implies [usubst]:
  "(P x \<Rightarrow> Q x)\<lbrakk>x\<rightarrow>v\<rbrakk> = ((P x)\<lbrakk>x\<rightarrow>v\<rbrakk> \<Rightarrow> (Q x)\<lbrakk>x\<rightarrow>v\<rbrakk>)"
  by (pred_auto)

lemma msubst_implies_2 [usubst]:
  "(P x y \<Rightarrow> Q x y)\<lbrakk>(x,y)\<rightarrow>v\<rbrakk> = ((P x y)\<lbrakk>(x,y)\<rightarrow>v\<rbrakk> \<Rightarrow> (Q x y)\<lbrakk>(x,y)\<rightarrow>v\<rbrakk>)"
  by (pred_auto)+

lemma msubst_shAll [usubst]:
  "(\<^bold>\<forall> x \<bullet> P x y)\<lbrakk>y\<rightarrow>v\<rbrakk> = (\<^bold>\<forall> x \<bullet> (P x y)\<lbrakk>y\<rightarrow>v\<rbrakk>)"
  by (pred_auto)

lemma msubst_shAll_2 [usubst]:
  "(\<^bold>\<forall> x \<bullet> P x y z)\<lbrakk>(y,z)\<rightarrow>v\<rbrakk> = (\<^bold>\<forall> x \<bullet> (P x y z)\<lbrakk>(y,z)\<rightarrow>v\<rbrakk>)"
  by (pred_auto)+

subsection \<open> Sandbox for conjectures \<close>

definition utp_sandbox :: "'\<alpha> upred \<Rightarrow> bool" ("TRY'(_')") where
"TRY(P) = (P = undefined)"

translations
  "P" <= "CONST utp_sandbox P"

end


(*  Title:      HOL/HOLCF/Ssum.thy
    Author:     Franz Regensburger
    Author:     Brian Huffman
*)

section {* The type of strict sums *}

theory Ssum
imports Tr
begin

default_sort pcpo

subsection {* Definition of strict sum type *}

definition
  "ssum =
    {p :: tr \<times> ('a \<times> 'b). p = \<bottom> \<or>
      (fst p = TT \<and> fst (snd p) \<noteq> \<bottom> \<and> snd (snd p) = \<bottom>) \<or>
      (fst p = FF \<and> fst (snd p) = \<bottom> \<and> snd (snd p) \<noteq> \<bottom>)}"

pcpodef ('a, 'b) ssum (infixr "++" 10) = "ssum :: (tr \<times> 'a \<times> 'b) set"
  unfolding ssum_def by simp_all

instance ssum :: ("{chfin,pcpo}", "{chfin,pcpo}") chfin
by (rule typedef_chfin [OF type_definition_ssum below_ssum_def])

type_notation (xsymbols)
  ssum  ("(_ \<oplus>/ _)" [21, 20] 20)
type_notation (HTML output)
  ssum  ("(_ \<oplus>/ _)" [21, 20] 20)

subsection {* Definitions of constructors *}

definition
  sinl :: "'a \<rightarrow> ('a ++ 'b)" where
  "sinl = (\<Lambda> a. Abs_ssum (seq\<cdot>a\<cdot>TT, a, \<bottom>))"

definition
  sinr :: "'b \<rightarrow> ('a ++ 'b)" where
  "sinr = (\<Lambda> b. Abs_ssum (seq\<cdot>b\<cdot>FF, \<bottom>, b))"

lemma sinl_ssum: "(seq\<cdot>a\<cdot>TT, a, \<bottom>) \<in> ssum"
by (simp add: ssum_def seq_conv_if)

lemma sinr_ssum: "(seq\<cdot>b\<cdot>FF, \<bottom>, b) \<in> ssum"
by (simp add: ssum_def seq_conv_if)

lemma Rep_ssum_sinl: "Rep_ssum (sinl\<cdot>a) = (seq\<cdot>a\<cdot>TT, a, \<bottom>)"
by (simp add: sinl_def cont_Abs_ssum Abs_ssum_inverse sinl_ssum)

lemma Rep_ssum_sinr: "Rep_ssum (sinr\<cdot>b) = (seq\<cdot>b\<cdot>FF, \<bottom>, b)"
by (simp add: sinr_def cont_Abs_ssum Abs_ssum_inverse sinr_ssum)

lemmas Rep_ssum_simps =
  Rep_ssum_inject [symmetric] below_ssum_def
  prod_eq_iff below_prod_def
  Rep_ssum_strict Rep_ssum_sinl Rep_ssum_sinr

subsection {* Properties of \emph{sinl} and \emph{sinr} *}

text {* Ordering *}

lemma sinl_below [simp]: "(sinl\<cdot>x \<sqsubseteq> sinl\<cdot>y) = (x \<sqsubseteq> y)"
by (simp add: Rep_ssum_simps seq_conv_if)

lemma sinr_below [simp]: "(sinr\<cdot>x \<sqsubseteq> sinr\<cdot>y) = (x \<sqsubseteq> y)"
by (simp add: Rep_ssum_simps seq_conv_if)

lemma sinl_below_sinr [simp]: "(sinl\<cdot>x \<sqsubseteq> sinr\<cdot>y) = (x = \<bottom>)"
by (simp add: Rep_ssum_simps seq_conv_if)

lemma sinr_below_sinl [simp]: "(sinr\<cdot>x \<sqsubseteq> sinl\<cdot>y) = (x = \<bottom>)"
by (simp add: Rep_ssum_simps seq_conv_if)

text {* Equality *}

lemma sinl_eq [simp]: "(sinl\<cdot>x = sinl\<cdot>y) = (x = y)"
by (simp add: po_eq_conv)

lemma sinr_eq [simp]: "(sinr\<cdot>x = sinr\<cdot>y) = (x = y)"
by (simp add: po_eq_conv)

lemma sinl_eq_sinr [simp]: "(sinl\<cdot>x = sinr\<cdot>y) = (x = \<bottom> \<and> y = \<bottom>)"
by (subst po_eq_conv, simp)

lemma sinr_eq_sinl [simp]: "(sinr\<cdot>x = sinl\<cdot>y) = (x = \<bottom> \<and> y = \<bottom>)"
by (subst po_eq_conv, simp)

lemma sinl_inject: "sinl\<cdot>x = sinl\<cdot>y \<Longrightarrow> x = y"
by (rule sinl_eq [THEN iffD1])

lemma sinr_inject: "sinr\<cdot>x = sinr\<cdot>y \<Longrightarrow> x = y"
by (rule sinr_eq [THEN iffD1])

text {* Strictness *}

lemma sinl_strict [simp]: "sinl\<cdot>\<bottom> = \<bottom>"
by (simp add: Rep_ssum_simps)

lemma sinr_strict [simp]: "sinr\<cdot>\<bottom> = \<bottom>"
by (simp add: Rep_ssum_simps)

lemma sinl_bottom_iff [simp]: "(sinl\<cdot>x = \<bottom>) = (x = \<bottom>)"
using sinl_eq [of "x" "\<bottom>"] by simp

lemma sinr_bottom_iff [simp]: "(sinr\<cdot>x = \<bottom>) = (x = \<bottom>)"
using sinr_eq [of "x" "\<bottom>"] by simp

lemma sinl_defined: "x \<noteq> \<bottom> \<Longrightarrow> sinl\<cdot>x \<noteq> \<bottom>"
by simp

lemma sinr_defined: "x \<noteq> \<bottom> \<Longrightarrow> sinr\<cdot>x \<noteq> \<bottom>"
by simp

text {* Compactness *}

lemma compact_sinl: "compact x \<Longrightarrow> compact (sinl\<cdot>x)"
by (rule compact_ssum, simp add: Rep_ssum_sinl)

lemma compact_sinr: "compact x \<Longrightarrow> compact (sinr\<cdot>x)"
by (rule compact_ssum, simp add: Rep_ssum_sinr)

lemma compact_sinlD: "compact (sinl\<cdot>x) \<Longrightarrow> compact x"
unfolding compact_def
by (drule adm_subst [OF cont_Rep_cfun2 [where f=sinl]], simp)

lemma compact_sinrD: "compact (sinr\<cdot>x) \<Longrightarrow> compact x"
unfolding compact_def
by (drule adm_subst [OF cont_Rep_cfun2 [where f=sinr]], simp)

lemma compact_sinl_iff [simp]: "compact (sinl\<cdot>x) = compact x"
by (safe elim!: compact_sinl compact_sinlD)

lemma compact_sinr_iff [simp]: "compact (sinr\<cdot>x) = compact x"
by (safe elim!: compact_sinr compact_sinrD)

subsection {* Case analysis *}

lemma ssumE [case_names bottom sinl sinr, cases type: ssum]:
  obtains "p = \<bottom>"
  | x where "p = sinl\<cdot>x" and "x \<noteq> \<bottom>"
  | y where "p = sinr\<cdot>y" and "y \<noteq> \<bottom>"
using Rep_ssum [of p] by (auto simp add: ssum_def Rep_ssum_simps)

lemma ssum_induct [case_names bottom sinl sinr, induct type: ssum]:
  "\<lbrakk>P \<bottom>;
   \<And>x. x \<noteq> \<bottom> \<Longrightarrow> P (sinl\<cdot>x);
   \<And>y. y \<noteq> \<bottom> \<Longrightarrow> P (sinr\<cdot>y)\<rbrakk> \<Longrightarrow> P x"
by (cases x, simp_all)

lemma ssumE2 [case_names sinl sinr]:
  "\<lbrakk>\<And>x. p = sinl\<cdot>x \<Longrightarrow> Q; \<And>y. p = sinr\<cdot>y \<Longrightarrow> Q\<rbrakk> \<Longrightarrow> Q"
by (cases p, simp only: sinl_strict [symmetric], simp, simp)

lemma below_sinlD: "p \<sqsubseteq> sinl\<cdot>x \<Longrightarrow> \<exists>y. p = sinl\<cdot>y \<and> y \<sqsubseteq> x"
by (cases p, rule_tac x="\<bottom>" in exI, simp_all)

lemma below_sinrD: "p \<sqsubseteq> sinr\<cdot>x \<Longrightarrow> \<exists>y. p = sinr\<cdot>y \<and> y \<sqsubseteq> x"
by (cases p, rule_tac x="\<bottom>" in exI, simp_all)

subsection {* Case analysis combinator *}

definition
  sscase :: "('a \<rightarrow> 'c) \<rightarrow> ('b \<rightarrow> 'c) \<rightarrow> ('a ++ 'b) \<rightarrow> 'c" where
  "sscase = (\<Lambda> f g s. (\<lambda>(t, x, y). If t then f\<cdot>x else g\<cdot>y) (Rep_ssum s))"

translations
  "case s of XCONST sinl\<cdot>x \<Rightarrow> t1 | XCONST sinr\<cdot>y \<Rightarrow> t2" == "CONST sscase\<cdot>(\<Lambda> x. t1)\<cdot>(\<Lambda> y. t2)\<cdot>s"
  "case s of (XCONST sinl :: 'a)\<cdot>x \<Rightarrow> t1 | XCONST sinr\<cdot>y \<Rightarrow> t2" => "CONST sscase\<cdot>(\<Lambda> x. t1)\<cdot>(\<Lambda> y. t2)\<cdot>s"

translations
  "\<Lambda>(XCONST sinl\<cdot>x). t" == "CONST sscase\<cdot>(\<Lambda> x. t)\<cdot>\<bottom>"
  "\<Lambda>(XCONST sinr\<cdot>y). t" == "CONST sscase\<cdot>\<bottom>\<cdot>(\<Lambda> y. t)"

lemma beta_sscase:
  "sscase\<cdot>f\<cdot>g\<cdot>s = (\<lambda>(t, x, y). If t then f\<cdot>x else g\<cdot>y) (Rep_ssum s)"
unfolding sscase_def by (simp add: cont_Rep_ssum)

lemma sscase1 [simp]: "sscase\<cdot>f\<cdot>g\<cdot>\<bottom> = \<bottom>"
unfolding beta_sscase by (simp add: Rep_ssum_strict)

lemma sscase2 [simp]: "x \<noteq> \<bottom> \<Longrightarrow> sscase\<cdot>f\<cdot>g\<cdot>(sinl\<cdot>x) = f\<cdot>x"
unfolding beta_sscase by (simp add: Rep_ssum_sinl)

lemma sscase3 [simp]: "y \<noteq> \<bottom> \<Longrightarrow> sscase\<cdot>f\<cdot>g\<cdot>(sinr\<cdot>y) = g\<cdot>y"
unfolding beta_sscase by (simp add: Rep_ssum_sinr)

lemma sscase4 [simp]: "sscase\<cdot>sinl\<cdot>sinr\<cdot>z = z"
by (cases z, simp_all)

subsection {* Strict sum preserves flatness *}

instance ssum :: (flat, flat) flat
apply (intro_classes, clarify)
apply (case_tac x, simp)
apply (case_tac y, simp_all add: flat_below_iff)
apply (case_tac y, simp_all add: flat_below_iff)
done

end


section \<open>Semi-Honest Security\<close>

text \<open>We follow the security definitions for the semi honest setting as described in \cite{DBLP:books/sp/17/Lindell17}.
In the semi honest model the parties are assumed not to deviate from the protocol transcript.
Semi honest security guarantees that no information is leaked during the running of the protocol.\<close>

subsection \<open>Security definitions\<close>

theory Semi_Honest_Def imports
  CryptHOL.CryptHOL
begin

subsubsection \<open>Security for deterministic functionalities\<close>

locale sim_det_def =
  fixes R1 :: "'msg1 \<Rightarrow> 'msg2 \<Rightarrow> 'view1 spmf"
    and S1  :: "'msg1 \<Rightarrow> 'out1 \<Rightarrow> 'view1 spmf"
    and R2 :: "'msg1 \<Rightarrow> 'msg2 \<Rightarrow> 'view2 spmf"
    and S2  :: "'msg2 \<Rightarrow> 'out2 \<Rightarrow> 'view2 spmf"
    and funct :: "'msg1 \<Rightarrow> 'msg2 \<Rightarrow> ('out1 \<times> 'out2) spmf"
    and protocol :: "'msg1 \<Rightarrow> 'msg2 \<Rightarrow> ('out1 \<times> 'out2) spmf"
  assumes lossless_R1: "lossless_spmf (R1 m1 m2)"
    and lossless_S1: "lossless_spmf (S1 m1 out1)"
    and lossless_R2: "lossless_spmf (R2 m1 m2)"
    and lossless_S2: "lossless_spmf (S2 m2 out2)"
    and lossless_funct: "lossless_spmf (funct m1 m2)"
begin

type_synonym 'view' adversary_det = "'view' \<Rightarrow> bool spmf"

definition "correctness m1 m2 \<equiv> (protocol m1 m2 = funct m1 m2)"

definition adv_P1 :: "'msg1 \<Rightarrow> 'msg2 \<Rightarrow> 'view1 adversary_det \<Rightarrow> real"
  where "adv_P1 m1 m2 D \<equiv> \<bar>(spmf (R1 m1 m2 \<bind> D) True)
            - spmf (funct m1 m2 \<bind> (\<lambda> (o1, o2). S1 m1 o1 \<bind> D)) True\<bar>"

definition "perfect_sec_P1 m1 m2 \<equiv> (R1 m1 m2 = funct m1 m2 \<bind> (\<lambda> (s1, s2). S1 m1 s1))"

definition adv_P2 :: "'msg1 \<Rightarrow> 'msg2 \<Rightarrow> 'view2 adversary_det \<Rightarrow> real"
  where "adv_P2 m1 m2 D = \<bar>spmf (R2 m1 m2 \<bind> (\<lambda> view. D view)) True
            - spmf (funct m1 m2 \<bind> (\<lambda> (o1, o2). S2 m2 o2 \<bind> (\<lambda> view. D view))) True\<bar>"

definition "perfect_sec_P2 m1 m2 \<equiv> (R2 m1 m2 = funct m1 m2 \<bind> (\<lambda> (s1, s2). S2 m2 s2))"

text \<open>We also define the security games (for Party 1 and 2) used in EasyCrypt to define semi honest security for Party 1.
We then show the two definitions are equivalent.\<close>

definition P1_game_alt :: "'msg1 \<Rightarrow> 'msg2 \<Rightarrow> 'view1 adversary_det \<Rightarrow> bool spmf"
  where "P1_game_alt m1 m2 D = do {
    b \<leftarrow> coin_spmf;
    (out1, out2) \<leftarrow> funct m1 m2;
    rview :: 'view1 \<leftarrow> R1 m1 m2;
    sview :: 'view1 \<leftarrow> S1 m1 out1;
    b' \<leftarrow> D (if b then rview else sview);
    return_spmf (b = b')}"

definition adv_P1_game :: "'msg1 \<Rightarrow> 'msg2 \<Rightarrow> 'view1 adversary_det \<Rightarrow> real"
  where "adv_P1_game m1 m2 D = \<bar>2*(spmf (P1_game_alt m1 m2 D ) True) - 1\<bar>"

text \<open>We show the two definitions are equivalent\<close>

lemma equiv_defs_P1:
  assumes lossless_D: "\<forall> view. lossless_spmf ((D:: 'view1 adversary_det) view)"
  shows "adv_P1_game m1 m2 D = adv_P1 m1 m2 D"
  including monad_normalisation
proof-
  have return_True_not_False: "spmf (return_spmf (b)) True = spmf (return_spmf (\<not> b)) False"
    for b by(cases b; auto)
  have lossless_ideal: "lossless_spmf ((funct m1 m2 \<bind> (\<lambda>(out1, out2). S1 m1 out1 \<bind> (\<lambda>sview. D sview \<bind> (\<lambda>b'. return_spmf (False = b'))))))"
    by(simp add: lossless_S1 lossless_funct lossless_weight_spmfD split_def lossless_D)
  have return: "spmf (funct m1 m2 \<bind> (\<lambda>(o1, o2). S1 m1 o1 \<bind> D)) True
                  = spmf (funct m1 m2 \<bind> (\<lambda>(o1, o2). S1 m1 o1 \<bind> (\<lambda> view. D view \<bind> (\<lambda> b. return_spmf b)))) True"
    by simp
  have "2*(spmf (P1_game_alt m1 m2 D ) True) - 1 = (spmf (R1 m1 m2 \<bind> (\<lambda>rview. D rview \<bind> (\<lambda>(b':: bool). return_spmf (True = b'))))) True
        - (1 - (spmf (funct m1 m2 \<bind> (\<lambda>(out1, out2). S1 m1 out1 \<bind> (\<lambda>sview. D sview \<bind> (\<lambda>b'. return_spmf (False = b')))))) True)"
    by(simp add: spmf_bind integral_spmf_of_set adv_P1_game_def P1_game_alt_def spmf_of_set
          UNIV_bool bind_spmf_const lossless_R1 lossless_S1 lossless_funct lossless_weight_spmfD)
   hence "adv_P1_game m1 m2 D = \<bar>(spmf (R1 m1 m2 \<bind> (\<lambda>rview. D rview \<bind> (\<lambda>(b':: bool). return_spmf (True = b'))))) True
        - (1 - (spmf (funct m1 m2 \<bind> (\<lambda>(out1, out2). S1 m1 out1 \<bind> (\<lambda>sview. D sview \<bind> (\<lambda>b'. return_spmf (False = b')))))) True)\<bar>"
     using adv_P1_game_def by simp
    also have "\<bar>(spmf (R1 m1 m2 \<bind> (\<lambda>rview. D rview \<bind> (\<lambda>(b':: bool). return_spmf (True = b'))))) True
                      - (1 - (spmf (funct m1 m2 \<bind> (\<lambda>(out1, out2). S1 m1 out1 \<bind> (\<lambda>sview. D sview
                            \<bind> (\<lambda>b'. return_spmf (False = b')))))) True)\<bar> = adv_P1 m1 m2 D"
    apply(simp only: adv_P1_def spmf_False_conv_True[symmetric] lossless_ideal; simp)
    by(simp only: return)(simp only: split_def spmf_bind return_True_not_False)
  ultimately show ?thesis by simp
qed

definition P2_game_alt :: "'msg1 \<Rightarrow> 'msg2 \<Rightarrow> 'view2 adversary_det \<Rightarrow> bool spmf"
  where "P2_game_alt m1 m2 D = do {
    b \<leftarrow> coin_spmf;
    (out1, out2) \<leftarrow> funct m1 m2;
    rview :: 'view2 \<leftarrow> R2 m1 m2;
    sview :: 'view2 \<leftarrow> S2 m2 out2;
    b' \<leftarrow> D (if b then rview else sview);
    return_spmf (b = b')}"

definition adv_P2_game :: "'msg1 \<Rightarrow> 'msg2 \<Rightarrow> 'view2 adversary_det \<Rightarrow> real"
  where "adv_P2_game m1 m2 D = \<bar>2*(spmf (P2_game_alt m1 m2 D ) True) - 1\<bar>"

lemma equiv_defs_P2:
  assumes lossless_D: "\<forall> view. lossless_spmf ((D:: 'view2 adversary_det) view)"
  shows "adv_P2_game m1 m2 D = adv_P2 m1 m2 D"
  including monad_normalisation
proof-
  have return_True_not_False: "spmf (return_spmf (b)) True = spmf (return_spmf (\<not> b)) False"
    for b by(cases b; auto)
  have lossless_ideal: "lossless_spmf ((funct m1 m2 \<bind> (\<lambda>(out1, out2). S2 m2 out2 \<bind> (\<lambda>sview. D sview \<bind> (\<lambda>b'. return_spmf (False = b'))))))"
      by(simp add: lossless_S2 lossless_funct lossless_weight_spmfD split_def lossless_D)
  have return: "spmf (funct m1 m2 \<bind> (\<lambda>(o1, o2). S2 m2 o2 \<bind> D)) True = spmf (funct m1 m2 \<bind> (\<lambda>(o1, o2). S2 m2 o2 \<bind> (\<lambda> view. D view \<bind> (\<lambda> b. return_spmf b)))) True"
    by simp
  have
    "2*(spmf (P2_game_alt m1 m2 D ) True) - 1 = (spmf (R2 m1 m2 \<bind> (\<lambda>rview. D rview \<bind> (\<lambda>(b':: bool). return_spmf (True = b'))))) True
        - (1 - (spmf (funct m1 m2 \<bind> (\<lambda>(out1, out2). S2 m2 out2 \<bind> (\<lambda>sview. D sview \<bind> (\<lambda>b'. return_spmf (False = b')))))) True)"
    by(simp add: spmf_bind integral_spmf_of_set adv_P1_game_def P2_game_alt_def spmf_of_set
          UNIV_bool bind_spmf_const lossless_R2 lossless_S2 lossless_funct lossless_weight_spmfD)
   hence "adv_P2_game m1 m2 D = \<bar>(spmf (R2 m1 m2 \<bind> (\<lambda>rview. D rview \<bind> (\<lambda>(b':: bool). return_spmf (True = b'))))) True
        - (1 - (spmf (funct m1 m2 \<bind> (\<lambda>(out1, out2). S2 m2 out2 \<bind> (\<lambda>sview. D sview \<bind> (\<lambda>b'. return_spmf (False = b')))))) True)\<bar>"
     using adv_P2_game_def by simp
    also have "\<bar>(spmf (R2 m1 m2 \<bind> (\<lambda>rview. D rview \<bind> (\<lambda>(b':: bool). return_spmf (True = b'))))) True
        - (1 - (spmf (funct m1 m2 \<bind> (\<lambda>(out1, out2). S2 m2 out2 \<bind> (\<lambda>sview. D sview \<bind> (\<lambda>b'. return_spmf (False = b')))))) True)\<bar> = adv_P2 m1 m2 D"
    apply(simp only: adv_P2_def spmf_False_conv_True[symmetric] lossless_ideal; simp)
    by(simp only: return)(simp only: split_def spmf_bind return_True_not_False)
  ultimately show ?thesis by simp
qed

end

subsubsection \<open> Security definitions for non deterministic functionalities \<close>

locale sim_non_det_def =
  fixes R1 :: "'msg1 \<Rightarrow> 'msg2 \<Rightarrow> ('view1 \<times> ('out1 \<times> 'out2)) spmf"
    and S1  :: "'msg1 \<Rightarrow> 'out1 \<Rightarrow> 'view1 spmf"
    and Out1 :: "'msg1 \<Rightarrow> 'msg2 \<Rightarrow> 'out1 \<Rightarrow> ('out1 \<times> 'out2) spmf" \<comment> \<open>takes the input of the other party so can form the outputs of parties\<close>
    and R2 :: "'msg1 \<Rightarrow> 'msg2 \<Rightarrow> ('view2 \<times> ('out1 \<times> 'out2)) spmf"
    and S2  :: "'msg2 \<Rightarrow> 'out2 \<Rightarrow> 'view2 spmf"
    and Out2 :: "'msg2 \<Rightarrow> 'msg1 \<Rightarrow> 'out2 \<Rightarrow> ('out1 \<times> 'out2) spmf"
    and funct :: "'msg1 \<Rightarrow> 'msg2 \<Rightarrow> ('out1 \<times> 'out2) spmf"
begin

type_synonym ('view', 'out1', 'out2') adversary_non_det = "('view' \<times> ('out1' \<times> 'out2')) \<Rightarrow> bool spmf"

definition Ideal1 :: "'msg1 \<Rightarrow> 'msg2 \<Rightarrow> 'out1  \<Rightarrow> ('view1 \<times> ('out1 \<times> 'out2)) spmf"
  where "Ideal1 m1 m2 out1 = do {
    view1 :: 'view1 \<leftarrow> S1 m1 out1;
    out1 \<leftarrow> Out1 m1 m2 out1;
    return_spmf (view1, out1)}"

definition Ideal2 :: "'msg2 \<Rightarrow> 'msg1 \<Rightarrow> 'out2 \<Rightarrow> ('view2 \<times> ('out1 \<times> 'out2)) spmf"
  where "Ideal2 m2 m1 out2 = do {
    view2 :: 'view2 \<leftarrow> S2 m2 out2;
    out2 \<leftarrow> Out2 m2 m1 out2;
    return_spmf (view2, out2)}"

definition adv_P1 :: "'msg1 \<Rightarrow> 'msg2 \<Rightarrow> ('view1, 'out1, 'out2) adversary_non_det \<Rightarrow> real"
  where "adv_P1 m1 m2 D \<equiv> \<bar>(spmf (R1 m1 m2 \<bind> (\<lambda> view. D view)) True) - spmf (funct m1 m2 \<bind> (\<lambda> (o1, o2). Ideal1 m1 m2 o1 \<bind> (\<lambda> view. D view))) True\<bar>"

definition "perfect_sec_P1 m1 m2 \<equiv> (R1 m1 m2 = funct m1 m2 \<bind> (\<lambda> (s1, s2). Ideal1 m1 m2 s1))"

definition adv_P2 :: "'msg1 \<Rightarrow> 'msg2 \<Rightarrow> ('view2, 'out1, 'out2) adversary_non_det \<Rightarrow> real"
  where "adv_P2 m1 m2 D = \<bar>spmf (R2 m1 m2 \<bind> (\<lambda> view. D view)) True - spmf (funct m1 m2 \<bind> (\<lambda> (o1, o2). Ideal2 m2 m1 o2 \<bind> (\<lambda> view. D view))) True\<bar>"

definition "perfect_sec_P2 m1 m2 \<equiv> (R2 m1 m2 = funct m1 m2 \<bind> (\<lambda> (s1, s2). Ideal2 m2 m1 s2))"

end

subsubsection \<open> Secret sharing schemes \<close>

locale secret_sharing_scheme =
  fixes share :: "'input_out \<Rightarrow> ('share \<times> 'share) spmf"
    and reconstruct :: "('share \<times> 'share) \<Rightarrow> 'input_out spmf"
    and F :: "('input_out \<Rightarrow> 'input_out \<Rightarrow> 'input_out spmf) set"
begin

definition "sharing_correct input \<equiv> (share input \<bind> (\<lambda> (s1,s2). reconstruct (s1,s2)) = return_spmf input)"

definition "correct_share_eval input1 input2 \<equiv> (\<forall> gate_eval \<in> F.
              \<exists> gate_protocol :: ('share \<times> 'share) \<Rightarrow> ('share \<times> 'share) \<Rightarrow> ('share \<times> 'share) spmf.
                  share input1 \<bind> (\<lambda> (s1,s2). share input2
                      \<bind> (\<lambda> (s3,s4). gate_protocol (s1,s3) (s2,s4)
                          \<bind> (\<lambda> (S1,S2). reconstruct (S1,S2)))) = gate_eval input1 input2)"

end

end


(*
  Author: Jose Divasón
  Email:  jose.divason@unirioja.es
*)

section \<open>Algorithm to transform a diagonal matrix into its Smith normal form in JNF\<close>

theory Diagonal_To_Smith_JNF
  imports Admits_SNF_From_Diagonal_Iff_Bezout_Ring
begin

text \<open>In this file, we implement an algorithm to transform a diagonal matrix into its Smith
normal form, using the JNF library.

There are, at least, three possible options:
\begin{enumerate}
\item Implement and prove the soundness of the algorithm from scratch in JNF
\item Implement it in JNF and connect it to the HOL Analysis version by means of transfer rules.
Thus, we could obtain the soundness lemma in JNF.
\item Implement it in JNF, with calls to the HOL Analysis version by means of the functions
@{text " from_hma\<^sub>m"} and @{text "to_hma\<^sub>m"}. That is, transform the matrix to HOL Analysis, apply
the existing algorith in HOL Analysis to get the Smith normal form and then transform the output
to JNF. Then, we could try to get the soundness theorem in JNF by means of
transfer rules and local type definitions.
\end{enumerate}

The first option requires much effort. As we will see, the third option is not possible.
\<close>

subsection \<open>Attempt with the third option: definitions and conditional transfer rules\<close>

context
  fixes A::"'a::bezout_ring mat"
  assumes "A \<in> carrier_mat CARD('nr::mod_type) CARD('nc::mod_type)"
begin

private definition "diagonal_to_Smith_PQ_JNF' bezout = (
  let A' = Mod_Type_Connect.to_hma\<^sub>m A::'a^'nc::mod_type^'nr::mod_type;
     (P,S,Q) = (diagonal_to_Smith_PQ A' bezout)
  in (Mod_Type_Connect.from_hma\<^sub>m P, Mod_Type_Connect.from_hma\<^sub>m S, Mod_Type_Connect.from_hma\<^sub>m Q))"

end

text \<open>This approach will not work. The type is necessary in the definition of the function.
That is, outside the context, the function will be:

@{text "diagonal_to_Smith_PQ_JNF' TYPE('nc) TYPE('nr) A bezout"}

And we cannot get rid of such @{text "TYPE('nc)"}.

That is, we could get a lemma like:

@{theory_text "
lemma
  assumes A \<in> carrier_mat m n
  and (P,S,Q) = diagonal_to_Smith_PQ_JNF' TYPE('nr::mod_type) TYPE('nc::mod_type) A bezout
  shows invertible_mat P \<and> invertible_mat Q \<and> S = P * A * Q \<and> Smith_normal_form_mat S
"}

But we wouldn't be able to get rid of such types.
\<close>

subsection \<open>Attempt with the second option: implementation and soundness in JNF\<close>

definition "diagonal_step_JNF A i j d v =
              Matrix.mat (dim_row A) (dim_col A) (\<lambda> (a,b). if a = i \<and> b = i then d else
               if a = j \<and> b = j
               then v * (A $$ (j,j)) else A $$ (a,b))"

text \<open>Conditional transfer rules are required, so I prove them within context with assumptions.\<close>

context
  includes lifting_syntax
  fixes i and j::nat
  assumes i: "i<min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
  and j: "j<min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
begin

lemma HMA_diagonal_step[transfer_rule]:
  "((Mod_Type_Connect.HMA_M :: _ \<Rightarrow> 'a :: comm_ring_1 ^ 'nc :: mod_type ^ 'nr :: mod_type \<Rightarrow> _)
    ===> (=) ===> (=) ===> Mod_Type_Connect.HMA_M)
    (\<lambda>A. diagonal_step_JNF A i j) (\<lambda>B. diagonal_step B i j)"
  by (intro rel_funI, goal_cases, auto simp add: Mod_Type_Connect.HMA_M_def
      diagonal_step_JNF_def diagonal_step_def)
 (rule eq_matI, auto simp add: Mod_Type_Connect.from_hma\<^sub>m_def, insert from_nat_eq_imp_eq i j, auto)

end

definition diagonal_step_PQ_JNF ::
  "'a::{bezout_ring} mat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a bezout \<Rightarrow> ('a mat \<times> ('a mat))"
  where "diagonal_step_PQ_JNF A i k bezout =
  (let  m = dim_row A; n = dim_col A;
        (p, q, u, v, d) = bezout (A $$ (i,i)) (A $$ (k,k));
        P = addrow (-v) k i (swaprows i k (addrow p k i (1\<^sub>m m)));
        Q = multcol k (-1) (addcol u k i (addcol q i k (1\<^sub>m n)))
        in (P,Q)
        )"

context
  includes lifting_syntax
  fixes i and k::nat
  assumes i: "i < min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
  and k: "k < min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
begin

lemma HMA_diagonal_step_PQ[transfer_rule]:
  "((Mod_Type_Connect.HMA_M :: _ \<Rightarrow> 'a :: bezout_ring ^ 'nc :: mod_type ^ 'nr :: mod_type \<Rightarrow> _)
    ===> (=) ===> rel_prod Mod_Type_Connect.HMA_M Mod_Type_Connect.HMA_M)
    (\<lambda>A bezout. diagonal_step_PQ_JNF A i k bezout) (\<lambda>A bezout. diagonal_step_PQ A i k bezout)"
proof (intro rel_funI, goal_cases)
  case (1 A A' bezout bezout')
  note HMA_M_AA'[transfer_rule] = 1(1)
  let ?d_JNF = "(diagonal_step_PQ_JNF A i k bezout)"
  let ?d_HA = "(diagonal_step_PQ A' i k bezout)"
  have [transfer_rule]: "Mod_Type_Connect.HMA_I k (from_nat k::'nc)"
    and [transfer_rule]: "Mod_Type_Connect.HMA_I k (from_nat k::'nr)"
    by (metis Mod_Type_Connect.HMA_I_def k min.strict_boundedE to_nat_from_nat_id)+
  have [transfer_rule]: "Mod_Type_Connect.HMA_I i (from_nat i::'nc)"
    and [transfer_rule]: "Mod_Type_Connect.HMA_I i (from_nat i::'nr)"
      by (metis Mod_Type_Connect.HMA_I_def i min.strict_boundedE to_nat_from_nat_id)+
  have [transfer_rule]: "A $$ (i,i) = A' $h from_nat i $h from_nat i"
  proof -
    have "A $$ (i,i) = index_hma A' (from_nat i) (from_nat i)"  by (transfer, simp)
    also have "... = A' $h from_nat i $h from_nat i" unfolding index_hma_def by auto
    finally show ?thesis .
  qed
  have [transfer_rule]: "A $$ (k,k) = A' $h from_nat k $h from_nat k"
  proof -
    have "A $$ (k,k) = index_hma A' (from_nat k) (from_nat k)"  by (transfer, simp)
    also have "... = A' $h from_nat k $h from_nat k" unfolding index_hma_def by auto
    finally show ?thesis .
  qed
  have dim_row_CARD: "dim_row A = CARD('nr)"
    using HMA_M_AA' Mod_Type_Connect.dim_row_transfer_rule by blast
  have dim_col_CARD: "dim_col A = CARD('nc)"
    using HMA_M_AA' Mod_Type_Connect.dim_col_transfer_rule by blast
  let ?p = "fst (bezout (A' $h from_nat i $h from_nat i) (A' $h from_nat k $h from_nat k))"
  let ?v = "fst (snd (snd (snd (bezout (A $$ (i, i)) (A $$ (k, k))))))"
  have "Mod_Type_Connect.HMA_M (fst ?d_JNF) (fst ?d_HA)"
    unfolding diagonal_step_PQ_JNF_def diagonal_step_PQ_def Mod_Type_Connect.HMA_M_def
    unfolding Let_def split_beta dim_row_CARD
    by (auto, transfer, auto simp add: Mod_Type_Connect.HMA_M_def Rel_def rel_funI)
  moreover have "Mod_Type_Connect.HMA_M (snd ?d_JNF) (snd ?d_HA)"
    unfolding diagonal_step_PQ_JNF_def diagonal_step_PQ_def Mod_Type_Connect.HMA_M_def
    unfolding Let_def split_beta dim_col_CARD
    by (auto, transfer, auto simp add: Mod_Type_Connect.HMA_M_def Rel_def rel_funI)
  ultimately show ?case unfolding rel_prod_conv using 1
    by (simp add: split_beta)
qed

end

fun diagonal_to_Smith_i_PQ_JNF ::
  "nat list \<Rightarrow> nat \<Rightarrow> ('a::{bezout_ring} bezout)
  \<Rightarrow> ('a mat \<times> 'a mat \<times> 'a mat) \<Rightarrow> ('a mat \<times> 'a mat \<times> 'a mat)"
 where
"diagonal_to_Smith_i_PQ_JNF [] i bezout (P,A,Q) = (P,A,Q)" |
"diagonal_to_Smith_i_PQ_JNF (j#xs) i bezout (P,A,Q) = (
  if A $$ (i,i) dvd A $$ (j,j)
     then diagonal_to_Smith_i_PQ_JNF xs i bezout (P,A,Q)
  else let (p, q, u, v, d) = bezout (A $$ (i,i)) (A $$ (j,j));
           A' = diagonal_step_JNF A i j d v;
          (P',Q') = diagonal_step_PQ_JNF A i j bezout
      in diagonal_to_Smith_i_PQ_JNF xs i bezout (P'*P,A',Q*Q') \<comment> \<open>Apply the step\<close>
  )
  "

context
  includes lifting_syntax
  fixes i and xs
  assumes i: "i < min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
  and xs: "\<forall>j\<in>set xs. j < min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
begin

declare diagonal_step_PQ.simps[simp del]

lemma HMA_diagonal_to_Smith_i_PQ_aux: "HMA_M3 (P,A,Q)
  (P' :: 'a :: bezout_ring ^ 'nr :: mod_type ^ 'nr :: mod_type,
   A' :: 'a :: bezout_ring ^ 'nc :: mod_type ^ 'nr :: mod_type,
   Q' :: 'a :: bezout_ring ^ 'nc :: mod_type ^ 'nc :: mod_type)
  \<Longrightarrow> HMA_M3 (diagonal_to_Smith_i_PQ_JNF xs i bezout (P,A,Q))
             (diagonal_to_Smith_i_PQ xs i bezout (P',A',Q'))"
  using i xs
proof (induct xs i bezout "(P',A',Q')" arbitrary: P' A' Q' P A Q rule: diagonal_to_Smith_i_PQ.induct)
  case (1 i bezout P' A' Q')
  then show ?case by auto
next
  case (2 j xs i bezout P' A' Q')
  note HMA_M3[transfer_rule] = "2.prems"(1)
  note i = 2(4)
  note j = 2(5)
  note IH1="2.hyps"(1)
  note IH2="2.hyps"(2)
  have j_min: "j < min CARD('nr) CARD('nc)" using j by auto
  have HMA_M_AA'[transfer_rule]: "Mod_Type_Connect.HMA_M A A'" using HMA_M3 by auto
  have [transfer_rule]: "Mod_Type_Connect.HMA_I j (from_nat j::'nc)"
    and [transfer_rule]: "Mod_Type_Connect.HMA_I j (from_nat j::'nr)"
    by (metis Mod_Type_Connect.HMA_I_def j_min min.strict_boundedE to_nat_from_nat_id)+
  have [transfer_rule]: "Mod_Type_Connect.HMA_I i (from_nat i::'nc)"
    and [transfer_rule]: "Mod_Type_Connect.HMA_I i (from_nat i::'nr)"
      by (metis Mod_Type_Connect.HMA_I_def i min.strict_boundedE to_nat_from_nat_id)+
  have [transfer_rule]: "A $$ (i, i) = A' $h from_nat i $h from_nat i"
  proof -
    have "A $$ (i,i) = index_hma A' (from_nat i) (from_nat i)"  by (transfer, simp)
    also have "... = A' $h from_nat i $h from_nat i" unfolding index_hma_def by auto
    finally show ?thesis .
  qed
  have [transfer_rule]: "A $$ (j, j) = A' $h from_nat j $h from_nat j"
  proof -
    have "A $$ (j,j) = index_hma A' (from_nat j) (from_nat j)"  by (transfer, simp)
    also have "... = A' $h from_nat j $h from_nat j" unfolding index_hma_def by auto
    finally show ?thesis .
  qed
  show ?case
  proof (cases "A $$ (i, i) dvd A $$ (j, j)")
    case True
    hence "A' $h from_nat i $h from_nat i dvd A' $h from_nat j $h from_nat j" by transfer
    then show ?thesis using True IH1 HMA_M3 i j by auto
  next
    case False
    obtain p q u v d where b: "(p, q, u, v, d) = bezout (A $$ (i,i)) (A $$ (j,j))"
      by (metis prod_cases5)
    let ?A'_JNF = "diagonal_step_JNF A i j d v"
    obtain P''_JNF Q''_JNF where P''Q''_JNF: "(P''_JNF,Q''_JNF) = diagonal_step_PQ_JNF A i j bezout"
      by (metis surjective_pairing)
    have not_dvd: "\<not> A' $h from_nat i $h from_nat i dvd A' $h from_nat j $h from_nat j" using False by transfer
    let ?A' = "diagonal_step A' i j d v"
    obtain P'' Q'' where P''Q'': "(P'',Q'') = diagonal_step_PQ A' i j bezout"
      by (metis surjective_pairing)
    have b2: "(p, q, u, v, d) = bezout (A' $h from_nat i $h from_nat i) (A' $h from_nat j $h from_nat j)"
      using b by (transfer,auto)
    let ?D_HA = "diagonal_to_Smith_i_PQ xs i bezout (P''**P',?A',Q'**Q'')"
    let ?D_JNF = "diagonal_to_Smith_i_PQ_JNF xs i bezout (P''_JNF*P,?A'_JNF,Q*Q''_JNF)"
    have rw_1: "diagonal_to_Smith_i_PQ_JNF (j # xs) i bezout (P, A, Q) = ?D_JNF"
      using False b P''Q''_JNF
      by (auto, unfold split_beta, metis fst_conv snd_conv)
    have rw_2: "diagonal_to_Smith_i_PQ (j # xs) i bezout (P', A', Q') = ?D_HA"
      using not_dvd b2 P''Q'' by (auto, unfold split_beta, metis fst_conv snd_conv)
    have "HMA_M3 ?D_JNF ?D_HA"
    proof (rule IH2[OF not_dvd b2], auto)
      have j: "j < min CARD('nr) CARD('nc)" using j by auto
      have [transfer_rule]: "rel_prod Mod_Type_Connect.HMA_M Mod_Type_Connect.HMA_M
       (diagonal_step_PQ_JNF A i j bezout) (diagonal_step_PQ A' i j bezout)"
        using HMA_diagonal_step_PQ[OF i j] HMA_M_AA' unfolding rel_fun_def by auto
      hence [transfer_rule]: "Mod_Type_Connect.HMA_M P''_JNF P''"
        and [transfer_rule]: "Mod_Type_Connect.HMA_M Q''_JNF Q''"
        using P''Q'' P''Q''_JNF unfolding rel_prod_conv split_beta
        by (metis fst_conv, metis snd_conv)
      have [transfer_rule]: "Mod_Type_Connect.HMA_M P P'" using HMA_M3 by auto
      show "Mod_Type_Connect.HMA_M (P''_JNF * P) (P'' ** P')"
        (* apply (transfer, auto) does not finish the goal*)
        by (transfer_prover_start, transfer_step+, auto)
     (* note HMA_diagonal_step[OF i j,transfer_rule]*)
     (*transfer does not work for the following goal*)
      show "Mod_Type_Connect.HMA_M (diagonal_step_JNF A i j d v) (diagonal_step A' i j d v)"
        using HMA_diagonal_step[OF i j] HMA_M_AA' unfolding rel_fun_def by auto
      have [transfer_rule]: "Mod_Type_Connect.HMA_M Q Q'" using HMA_M3 by auto
      show "Mod_Type_Connect.HMA_M (Q * Q''_JNF) (Q' ** Q'')"
        by (transfer_prover_start, transfer_step+, auto)
    qed (insert i j P''Q'', auto)
    then show ?thesis using rw_1 rw_2 by auto
  qed
qed

lemma HMA_diagonal_to_Smith_i_PQ[transfer_rule]:
  "((=)
  ===> (HMA_M3 :: (_ \<Rightarrow> (_\<times>('a :: bezout_ring ^ 'nc :: mod_type ^ 'nr :: mod_type) \<times> _) \<Rightarrow>_))
  ===> HMA_M3) (diagonal_to_Smith_i_PQ_JNF xs i) (diagonal_to_Smith_i_PQ xs i)"
proof (intro rel_funI, goal_cases)
  case (1 x y bezout bezout')
  then show ?case using HMA_diagonal_to_Smith_i_PQ_aux
    by (auto, smt HMA_M3.elims(2))
qed

end

fun Diagonal_to_Smith_row_i_PQ_JNF
  where "Diagonal_to_Smith_row_i_PQ_JNF i bezout (P,A,Q)
  = diagonal_to_Smith_i_PQ_JNF [i + 1..<min (dim_row A) (dim_col A)] i bezout (P,A,Q)"

declare Diagonal_to_Smith_row_i_PQ_JNF.simps[simp del]
lemmas Diagonal_to_Smith_row_i_PQ_JNF_def = Diagonal_to_Smith_row_i_PQ_JNF.simps

context
  includes lifting_syntax
  fixes i
  assumes i: "i < min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
begin

lemma HMA_Diagonal_to_Smith_row_i_PQ[transfer_rule]:
  "((=) ===> (HMA_M3 :: (_ \<Rightarrow> (_ \<times> ('a::bezout_ring^'nc::mod_type^'nr::mod_type) \<times> _) \<Rightarrow> _)) ===> HMA_M3)
  (Diagonal_to_Smith_row_i_PQ_JNF i) (Diagonal_to_Smith_row_i_PQ i)"
proof (intro rel_funI, clarify, goal_cases)
  case (1 _ bezout P A Q P' A' Q')
  note HMA_M3[transfer_rule] = 1
  let ?xs1="[i + 1..<min (dim_row A) (dim_col A)]"
  let ?xs2="[i + 1..<min (nrows A') (ncols A')]"
  have xs_eq[transfer_rule]: "?xs1 = ?xs2"
    using HMA_M3
    by (auto intro: arg_cong2[where f = upt]
        simp: Mod_Type_Connect.dim_col_transfer_rule Mod_Type_Connect.dim_row_transfer_rule
        nrows_def ncols_def)
  have j_xs: "\<forall>j\<in>set ?xs1. j < min CARD('nr) CARD('nc)" using i
    by (metis atLeastLessThan_iff ncols_def nrows_def set_upt xs_eq)
  have rel: "HMA_M3 (diagonal_to_Smith_i_PQ_JNF ?xs1 i bezout (P,A,Q))
            (diagonal_to_Smith_i_PQ ?xs1 i bezout (P',A',Q'))"
  using HMA_diagonal_to_Smith_i_PQ[OF i j_xs] HMA_M3 unfolding rel_fun_def by blast
  then show ?case
    unfolding Diagonal_to_Smith_row_i_PQ_JNF_def Diagonal_to_Smith_row_i_PQ_def
    by (metis Suc_eq_plus1 xs_eq)
qed

end

fun diagonal_to_Smith_aux_PQ_JNF
  where
  "diagonal_to_Smith_aux_PQ_JNF [] bezout (P,A,Q) = (P,A,Q)" |
  "diagonal_to_Smith_aux_PQ_JNF (i#xs) bezout (P,A,Q)
      = diagonal_to_Smith_aux_PQ_JNF xs bezout (Diagonal_to_Smith_row_i_PQ_JNF i bezout (P,A,Q))"

context
  includes lifting_syntax
  fixes xs
  assumes xs: "\<forall>j\<in>set xs. j < min (CARD('nr::mod_type)) (CARD('nc::mod_type))"
begin

lemma HMA_diagonal_to_Smith_aux_PQ_JNF[transfer_rule]:
  "((=) ===> (HMA_M3 :: (_ \<Rightarrow> (_ \<times> ('a::bezout_ring^'nc::mod_type^'nr::mod_type) \<times> _) \<Rightarrow> _)) ===> HMA_M3)
  (diagonal_to_Smith_aux_PQ_JNF xs) (diagonal_to_Smith_aux_PQ xs)"
proof (intro rel_funI, clarify, goal_cases)
  case (1 _ bezout P A Q P' A' Q')
  note HMA_M3[transfer_rule] = 1
  show ?case
    using xs HMA_M3
  proof (induct xs arbitrary: P' A' Q' P A Q)
    case Nil
    then show ?case by auto
  next
    case (Cons i xs)
    note IH = Cons(1)
    note HMA_M3 = Cons.prems(2)
    have i: "i < min CARD('nr) CARD('nc)" using Cons.prems by auto
    let ?D_JNF = "(Diagonal_to_Smith_row_i_PQ_JNF i bezout (P, A, Q))"
    let ?D_HA = "(Diagonal_to_Smith_row_i_PQ i bezout (P', A', Q'))"
    have rw_1: "diagonal_to_Smith_aux_PQ_JNF (i # xs) bezout (P, A, Q)
        = diagonal_to_Smith_aux_PQ_JNF xs bezout ?D_JNF" by auto
    have rw_2: "diagonal_to_Smith_aux_PQ (i # xs) bezout (P', A', Q')
        = diagonal_to_Smith_aux_PQ xs bezout ?D_HA" by auto
    have "HMA_M3 ?D_JNF ?D_HA"
      using HMA_Diagonal_to_Smith_row_i_PQ[OF i] HMA_M3 unfolding rel_fun_def by blast
    then show ?case
      by (auto, smt Cons.hyps HMA_M3.elims(2) list.set_intros(2) local.Cons(2))
  qed
qed

end

fun diagonal_to_Smith_PQ_JNF
  where "diagonal_to_Smith_PQ_JNF A bezout
  = diagonal_to_Smith_aux_PQ_JNF [0..<min (dim_row A) (dim_col A) - 1]
    bezout (1\<^sub>m (dim_row A),A,1\<^sub>m (dim_col A))"

declare diagonal_to_Smith_PQ_JNF.simps[simp del]
lemmas diagonal_to_Smith_PQ_JNF_def = diagonal_to_Smith_PQ_JNF.simps

lemma diagonal_step_PQ_JNF_dim:
  assumes A: "A \<in> carrier_mat m n"
    and d: "diagonal_step_PQ_JNF A i j bezout = (P,Q)"
  shows "P \<in> carrier_mat m m \<and> Q \<in> carrier_mat n n"
  using A d unfolding diagonal_step_PQ_JNF_def split_beta Let_def by auto

lemma diagonal_step_JNF_dim:
  assumes A: "A \<in> carrier_mat m n"
  shows "diagonal_step_JNF A i j d v \<in> carrier_mat m n"
  using A unfolding diagonal_step_JNF_def by auto

lemma diagonal_to_Smith_i_PQ_JNF_dim:
  assumes "P' \<in> carrier_mat m m \<and> A' \<in> carrier_mat m n \<and> Q' \<in> carrier_mat n n"
    and "diagonal_to_Smith_i_PQ_JNF xs i bezout (P',A',Q') = (P,A,Q)"
  shows "P \<in> carrier_mat m m \<and> A \<in> carrier_mat m n \<and> Q \<in> carrier_mat n n"
  using assms
  proof (induct xs i bezout "(P',A',Q')" arbitrary: P A Q P' A' Q' rule: diagonal_to_Smith_i_PQ_JNF.induct)
    case (1 i bezout P A Q)
    then show ?case by auto
  next
    case (2 j xs i bezout P' A' Q')
    show ?case
    proof (cases "A' $$ (i, i) dvd A' $$ (j, j)")
      case True
      then show ?thesis using 2 by auto
    next
      case False
      obtain p q u v d where b: "(p, q, u, v, d) = bezout (A' $$ (i,i)) (A' $$ (j,j))"
      by (metis prod_cases5)
      let ?A' = "diagonal_step_JNF A' i j d v"
      obtain P'' Q'' where P''Q'': "(P'',Q'') = diagonal_step_PQ_JNF A' i j bezout"
        by (metis surjective_pairing)
      let ?A' = "diagonal_step_JNF A' i j d v"
      let ?D_JNF = "diagonal_to_Smith_i_PQ_JNF xs i bezout (P''*P',?A',Q'*Q'')"
      have rw_1: "diagonal_to_Smith_i_PQ_JNF (j # xs) i bezout (P', A', Q') = ?D_JNF"
        using False b P''Q''
        by (auto, unfold split_beta, metis fst_conv snd_conv)
      show ?thesis
      proof (rule "2.hyps"(2)[OF False b])
        show "?D_JNF = (P,A,Q)" using rw_1 2 by auto
        have "P'' \<in> carrier_mat m m" and "Q'' \<in> carrier_mat n n"
          using diagonal_step_PQ_JNF_dim[OF _ P''Q''[symmetric]] "2.prems" by auto
        thus "P'' * P' \<in> carrier_mat m m \<and> ?A' \<in> carrier_mat m n \<and> Q' * Q'' \<in> carrier_mat n n"
          using diagonal_step_JNF_dim 2 by (metis mult_carrier_mat)
    qed (insert P''Q'', auto)
  qed
qed

lemma Diagonal_to_Smith_row_i_PQ_JNF_dim:
  assumes "P' \<in> carrier_mat m m \<and> A' \<in> carrier_mat m n \<and> Q' \<in> carrier_mat n n"
    and "Diagonal_to_Smith_row_i_PQ_JNF i bezout (P',A',Q') = (P,A,Q)"
  shows "P \<in> carrier_mat m m \<and> A \<in> carrier_mat m n \<and> Q \<in> carrier_mat n n"
  by (rule diagonal_to_Smith_i_PQ_JNF_dim, insert assms,
      auto simp add: Diagonal_to_Smith_row_i_PQ_JNF_def)

lemma diagonal_to_Smith_aux_PQ_JNF_dim:
  assumes "P' \<in> carrier_mat m m \<and> A' \<in> carrier_mat m n \<and> Q' \<in> carrier_mat n n"
    and "diagonal_to_Smith_aux_PQ_JNF xs bezout (P',A',Q') = (P,A,Q)"
  shows "P \<in> carrier_mat m m \<and> A \<in> carrier_mat m n \<and> Q \<in> carrier_mat n n"
  using assms
  proof (induct xs bezout "(P',A',Q')" arbitrary: P A Q P' A' Q' rule: diagonal_to_Smith_aux_PQ_JNF.induct)
    case (1 bezout P A Q)
    then show ?case by simp
  next
    case (2 i xs bezout P' A' Q')
    let ?D="(Diagonal_to_Smith_row_i_PQ_JNF i bezout (P', A', Q'))"
    have "diagonal_to_Smith_aux_PQ_JNF (i # xs) bezout (P', A', Q') =
      diagonal_to_Smith_aux_PQ_JNF xs bezout ?D" by auto
    hence *: "... = (P,A,Q)" using 2 by auto
    let ?P="fst ?D"
    let ?S="fst (snd ?D)"
    let ?Q="snd (snd ?D)"
    show ?case
    proof (rule "2.hyps")
      show "Diagonal_to_Smith_row_i_PQ_JNF i bezout (P', A', Q') = (?P,?S,?Q)" by auto
      show "diagonal_to_Smith_aux_PQ_JNF xs bezout (?P, ?S, ?Q) = (P, A, Q)" using * by simp
      show "?P \<in> carrier_mat m m \<and> ?S \<in> carrier_mat m n \<and> ?Q \<in> carrier_mat n n"
        by (rule Diagonal_to_Smith_row_i_PQ_JNF_dim, insert 2, auto)
    qed
qed

lemma diagonal_to_Smith_PQ_JNF_dim:
  assumes "A \<in> carrier_mat m n"
    and PSQ: "diagonal_to_Smith_PQ_JNF A bezout = (P,S,Q)"
  shows "P \<in> carrier_mat m m \<and> S \<in> carrier_mat m n \<and> Q \<in> carrier_mat n n"
  by (rule diagonal_to_Smith_aux_PQ_JNF_dim, insert assms,
      auto simp add: diagonal_to_Smith_PQ_JNF_def)

context
  includes lifting_syntax
begin

lemma HMA_diagonal_to_Smith_PQ_JNF[transfer_rule]:
 "((Mod_Type_Connect.HMA_M) ===> (=) ===> HMA_M3) (diagonal_to_Smith_PQ_JNF) (diagonal_to_Smith_PQ)"
proof (intro rel_funI, clarify, goal_cases)
  case (1 A A' _ bezout)
  let ?xs1 = "[0..<min (dim_row A) (dim_col A) - 1]"
  let ?xs2 = "[0..<min (nrows A') (ncols A') - 1]"
  let ?PAQ="(1\<^sub>m (dim_row A), A, 1\<^sub>m (dim_col A))"
  have dr: "dim_row A = CARD('c)"
    using 1 Mod_Type_Connect.dim_row_transfer_rule by blast
  have dc: "dim_col A = CARD('b)"
    using 1 Mod_Type_Connect.dim_col_transfer_rule by blast
  have xs_eq: "?xs1 = ?xs2"
    by (simp add: dc dr ncols_def nrows_def)
  have j_xs: "\<forall>j\<in>set ?xs1. j < min CARD('c) CARD('b)"
    using dc dr less_imp_diff_less by auto
  let ?D_JNF = "diagonal_to_Smith_aux_PQ_JNF ?xs1 bezout ?PAQ"
  let ?D_HA = "diagonal_to_Smith_aux_PQ ?xs1 bezout (mat 1, A', mat 1)"
  have mat_rel_init: "HMA_M3 ?PAQ (mat 1, A', mat 1)"
  proof -
    have "Mod_Type_Connect.HMA_M (1\<^sub>m (dim_row A)) (mat 1::'a^'c::mod_type^'c::mod_type)"
      unfolding dr by (transfer_prover_start,transfer_step, auto)
    moreover have "Mod_Type_Connect.HMA_M (1\<^sub>m (dim_col A)) (mat 1::'a^'b::mod_type^'b::mod_type)"
      unfolding dc by (transfer_prover_start,transfer_step, auto)
    ultimately show ?thesis using 1 by auto
  qed
  have "HMA_M3 ?D_JNF ?D_HA"
    using HMA_diagonal_to_Smith_aux_PQ_JNF[OF j_xs] mat_rel_init unfolding rel_fun_def by blast
  then show ?case using xs_eq unfolding diagonal_to_Smith_PQ_JNF_def diagonal_to_Smith_PQ_def
    by auto
qed

end

subsection \<open>Applying local type definitions\<close>

text \<open>Now we get the soundness lemma in JNF, via the one in HOL Analysis. I need transfer rules
and local type definitions.\<close>

context
  includes lifting_syntax
begin

private lemma diagonal_to_Smith_PQ_JNF_with_types:
  assumes A: "A \<in> carrier_mat CARD('nr::mod_type) CARD('nc::mod_type)"
  and S: "S \<in> carrier_mat CARD('nr) CARD('nc)"
  and P: "P \<in> carrier_mat CARD('nr) CARD('nr)"
  and Q: "Q \<in> carrier_mat CARD('nc) CARD('nc)"
  and PSQ: "diagonal_to_Smith_PQ_JNF A bezout = (P, S, Q)"
  and d:"isDiagonal_mat A" and ib: "is_bezout_ext bezout"
shows "S = P * A * Q \<and> invertible_mat P \<and> invertible_mat Q \<and> Smith_normal_form_mat S"
proof -
  let ?P = "Mod_Type_Connect.to_hma\<^sub>m P::'a^'nr::mod_type^'nr::mod_type"
  let ?A = "Mod_Type_Connect.to_hma\<^sub>m A::'a^'nc::mod_type^'nr::mod_type"
  let ?Q = "Mod_Type_Connect.to_hma\<^sub>m Q::'a^'nc::mod_type^'nc::mod_type"
  let ?S = "Mod_Type_Connect.to_hma\<^sub>m S::'a^'nc::mod_type^'nr::mod_type"
  have [transfer_rule]: "Mod_Type_Connect.HMA_M A ?A"
    by (simp add: Mod_Type_Connect.HMA_M_def A)
  moreover have [transfer_rule]: "Mod_Type_Connect.HMA_M P ?P"
    by (simp add: Mod_Type_Connect.HMA_M_def P)
  moreover have [transfer_rule]: "Mod_Type_Connect.HMA_M Q ?Q"
    by (simp add: Mod_Type_Connect.HMA_M_def Q)
  moreover have [transfer_rule]: "Mod_Type_Connect.HMA_M S ?S"
    by (simp add: Mod_Type_Connect.HMA_M_def S)
  ultimately have [transfer_rule]: "HMA_M3 (P,S,Q) (?P,?S,?Q)" by simp
  have [transfer_rule]: "bezout = bezout" ..
  have PSQ2: "(?P,?S,?Q) = diagonal_to_Smith_PQ ?A bezout" by (transfer, insert PSQ, auto)
  have "?S = ?P**?A**?Q \<and> invertible ?P \<and> invertible ?Q \<and> Smith_normal_form ?S"
    by (rule diagonal_to_Smith_PQ'[OF _ ib PSQ2], transfer, auto simp add: d)
  with this[untransferred] show ?thesis by auto
qed

private lemma diagonal_to_Smith_PQ_JNF_mod_ring_with_types:
  assumes A: "A \<in> carrier_mat CARD('nr::nontriv mod_ring) CARD('nc::nontriv mod_ring)"
  and S: "S \<in> carrier_mat CARD('nr mod_ring) CARD('nc mod_ring)"
  and P: "P \<in> carrier_mat CARD('nr mod_ring) CARD('nr mod_ring)"
  and Q: "Q \<in> carrier_mat CARD('nc mod_ring) CARD('nc mod_ring)"
  and PSQ: "diagonal_to_Smith_PQ_JNF A bezout = (P, S, Q)"
  and d:"isDiagonal_mat A" and ib: "is_bezout_ext bezout"
shows "S = P * A * Q \<and> invertible_mat P \<and> invertible_mat Q \<and> Smith_normal_form_mat S"
  by (rule diagonal_to_Smith_PQ_JNF_with_types[OF assms])

(*I don't know how to internalize the sort constraint of 'nr and 'nc at once,
so I do it in two steps.*)
thm diagonal_to_Smith_PQ_JNF_mod_ring_with_types[unfolded CARD_mod_ring,
      internalize_sort "'nr::nontriv"]

private lemma diagonal_to_Smith_PQ_JNF_internalized_first:
  "class.nontriv TYPE('a::type) \<Longrightarrow>
  A \<in> carrier_mat CARD('a) CARD('nc::nontriv) \<Longrightarrow>
  S \<in> carrier_mat CARD('a) CARD('nc) \<Longrightarrow>
  P \<in> carrier_mat CARD('a) CARD('a) \<Longrightarrow>
  Q \<in> carrier_mat CARD('nc) CARD('nc) \<Longrightarrow>
  diagonal_to_Smith_PQ_JNF A bezout = (P, S, Q) \<Longrightarrow>
  isDiagonal_mat A \<Longrightarrow> is_bezout_ext bezout \<Longrightarrow>
  S = P * A * Q \<and> invertible_mat P \<and> invertible_mat Q \<and> Smith_normal_form_mat S"
  using diagonal_to_Smith_PQ_JNF_mod_ring_with_types[unfolded CARD_mod_ring,
      internalize_sort "'nr::nontriv"] by blast

private lemma diagonal_to_Smith_PQ_JNF_internalized:
  "class.nontriv TYPE('c::type) \<Longrightarrow>
  class.nontriv TYPE('a::type) \<Longrightarrow>
  A \<in> carrier_mat CARD('a) CARD('c) \<Longrightarrow>
  S \<in> carrier_mat CARD('a) CARD('c) \<Longrightarrow>
  P \<in> carrier_mat CARD('a) CARD('a) \<Longrightarrow>
  Q \<in> carrier_mat CARD('c) CARD('c) \<Longrightarrow>
  diagonal_to_Smith_PQ_JNF A bezout = (P, S, Q) \<Longrightarrow>
  isDiagonal_mat A \<Longrightarrow> is_bezout_ext bezout \<Longrightarrow>
S = P * A * Q \<and> invertible_mat P \<and> invertible_mat Q \<and> Smith_normal_form_mat S"
  using diagonal_to_Smith_PQ_JNF_internalized_first[internalize_sort "'nc::nontriv"] by blast

context
  fixes m::nat and n::nat
  assumes local_typedef1: "\<exists>(Rep :: ('b \<Rightarrow> int)) Abs. type_definition Rep Abs {0..<m :: int}"
  assumes local_typedef2: "\<exists>(Rep :: ('c \<Rightarrow> int)) Abs. type_definition Rep Abs {0..<n :: int}"
  and m: "m>1"
  and n: "n>1"
begin

lemma type_to_set1:
  shows "class.nontriv TYPE('b)" (is ?a) and "m=CARD('b)" (is ?b)
proof -
  from local_typedef1 obtain Rep::"('b \<Rightarrow> int)" and Abs
    where t: "type_definition Rep Abs {0..<m :: int}" by auto
  have "card (UNIV :: 'b set) = card {0..<m}" using t type_definition.card by fastforce
  also have "... = m" by auto
  finally show ?b ..
  then show ?a unfolding class.nontriv_def using m by auto
qed

lemma type_to_set2:
  shows "class.nontriv TYPE('c)" (is ?a) and "n=CARD('c)" (is ?b)
proof -
  from local_typedef2 obtain Rep::"('c \<Rightarrow> int)" and Abs
    where t: "type_definition Rep Abs {0..<n :: int}" by blast
  have "card (UNIV :: 'c set) = card {0..<n}" using t type_definition.card by force
  also have "... = n" by auto
  finally show ?b ..
  then show ?a unfolding class.nontriv_def using n by auto
qed

lemma diagonal_to_Smith_PQ_JNF_local_typedef:
  assumes A: "isDiagonal_mat A" and ib: "is_bezout_ext bezout"
  and A_dim: "A \<in> carrier_mat m n"
  assumes PSQ: "(P,S,Q) = diagonal_to_Smith_PQ_JNF A bezout"
  shows "S = P*A*Q \<and> invertible_mat P \<and> invertible_mat Q \<and> Smith_normal_form_mat S
  \<and> P \<in> carrier_mat m m \<and> S \<in> carrier_mat m n \<and> Q \<in> carrier_mat n n"
proof -
  have dim_matrices: "P \<in> carrier_mat m m \<and> S \<in> carrier_mat m n \<and> Q \<in> carrier_mat n n"
    by (rule diagonal_to_Smith_PQ_JNF_dim[OF A_dim PSQ[symmetric]])
  show ?thesis
  using diagonal_to_Smith_PQ_JNF_internalized[where ?'c='c, where ?'a='b,
      OF type_to_set2(1) type_to_set(1), of m A S P Q]
  unfolding type_to_set1(2)[symmetric] type_to_set2(2)[symmetric]
  using assms m dim_matrices local_typedef1 by auto
qed
end
end

(*Canceling the first local type definitions (I was not able to cancel both in one step)*)
context
begin
private lemma diagonal_to_Smith_PQ_JNF_canceled_first:
  "\<exists>Rep Abs. type_definition Rep Abs {0..<int n} \<Longrightarrow> {0..<int m} \<noteq> {} \<Longrightarrow>
  1 < m \<Longrightarrow> 1 < n \<Longrightarrow> isDiagonal_mat A \<Longrightarrow> is_bezout_ext bezout \<Longrightarrow>
  A \<in> carrier_mat m n \<Longrightarrow> (P, S, Q) = diagonal_to_Smith_PQ_JNF A bezout \<Longrightarrow>
  S = P * A * Q \<and> invertible_mat P \<and> invertible_mat Q \<and> Smith_normal_form_mat S
  \<and> P \<in> carrier_mat m m \<and> S \<in> carrier_mat m n \<and> Q \<in> carrier_mat n n"
  using diagonal_to_Smith_PQ_JNF_local_typedef[cancel_type_definition] by blast

(*Canceling the second*)
private lemma diagonal_to_Smith_PQ_JNF_canceled_both:
  "{0..<int n} \<noteq> {} \<Longrightarrow> {0..<int m} \<noteq> {} \<Longrightarrow> 1 < m \<Longrightarrow> 1 < n \<Longrightarrow>
  isDiagonal_mat A \<Longrightarrow> is_bezout_ext bezout \<Longrightarrow> A \<in> carrier_mat m n \<Longrightarrow>
  (P, S, Q) = diagonal_to_Smith_PQ_JNF A bezout \<Longrightarrow> S = P * A * Q \<and>
  invertible_mat P \<and> invertible_mat Q \<and> Smith_normal_form_mat S
  \<and> P \<in> carrier_mat m m \<and> S \<in> carrier_mat m n \<and> Q \<in> carrier_mat n n"
  using diagonal_to_Smith_PQ_JNF_canceled_first[cancel_type_definition] by blast

subsection \<open>The final result\<close>

lemma diagonal_to_Smith_PQ_JNF:
  assumes A: "isDiagonal_mat A" and ib: "is_bezout_ext bezout"
  and "A \<in> carrier_mat m n"
  and PBQ: "(P,S,Q) = diagonal_to_Smith_PQ_JNF A bezout"
(*The following two assumptions appear since mod_type requires 1<CARD.
Those cases could be treated separately.*)
  and n: "n>1" and m: "m>1"
  shows "S = P*A*Q \<and> invertible_mat P \<and> invertible_mat Q \<and> Smith_normal_form_mat S
  \<and> P \<in> carrier_mat m m \<and> S \<in> carrier_mat m n \<and> Q \<in> carrier_mat n n"
  using diagonal_to_Smith_PQ_JNF_canceled_both[OF _ _ m n] using assms by force
end
end


(*******************************************************************************

  Project: Refining Authenticated Key Agreement with Strong Adversaries

  Module:  Secrecy.thy (Isabelle/HOL 2016-1)
  ID:      $Id: Secrecy.thy 133008 2017-01-17 13:53:14Z csprenge $
  Author:  Joseph Lallemand, INRIA Nancy <joseph.lallemand@loria.fr>
           Christoph Sprenger, ETH Zurich <sprenger@inf.ethz.ch>

  A simple model of secrecy with a set of secrets and the intruder knowledge.
  Secrecy = disjointness of secret messages and intruder knowledge
  Two events: (1) secret declaration (later by protocols)
              (2) intruder learns a message

  Copyright (c) 2015-2016 Joseph Lallemand and Christoph Sprenger
  Licence: LGPL

*******************************************************************************)

section \<open>Secrecy Model (L0)\<close>

theory Secrecy
imports Refinement IK
begin

declare domIff [simp, iff del]

(**************************************************************************************************)
subsection \<open>State and events\<close>
(**************************************************************************************************)

text \<open>Level 0 secrecy state: extend intruder knowledge with set of secrets.\<close>

record s0_state = ik_state +
  secret :: "msg set"

text \<open>Definition of the secrecy invariant: DY closure of intruder knowledge and set of
secrets are disjoint.\<close>

definition
  s0_secrecy :: "'a s0_state_scheme set"
where
  "s0_secrecy \<equiv> {s. synth (analz (ik s)) \<inter> secret s = {}}"

lemmas s0_secrecyI = s0_secrecy_def [THEN setc_def_to_intro, rule_format]
lemmas s0_secrecyE [elim] = s0_secrecy_def [THEN setc_def_to_elim, rule_format]

text \<open>Two events: add/declare a message as a secret and learn a (non-secret) message.\<close>

definition
  s0_add_secret :: "msg \<Rightarrow> ('a s0_state_scheme * 'a s0_state_scheme) set"
where
  "s0_add_secret m \<equiv> {(s,s').
    \<comment> \<open>guard\<close>
    m \<notin> synth (analz (ik s)) \<and>

    \<comment> \<open>action\<close>
    s' = s\<lparr>secret := insert m (secret s)\<rparr>
  }"

definition
  s0_learn :: "msg \<Rightarrow> ('a s0_state_scheme * 'a s0_state_scheme) set"
where
  "s0_learn m \<equiv> {(s,s').
    \<comment> \<open>guard\<close>
    s\<lparr>ik := insert m (ik s)\<rparr> \<in> s0_secrecy \<and>

    \<comment> \<open>action\<close>
    s' = s\<lparr>ik := insert m (ik s)\<rparr>
  }"

definition
  s0_learn' :: "msg \<Rightarrow> ('a s0_state_scheme * 'a s0_state_scheme) set"
where
  "s0_learn' m \<equiv> {(s,s').
    \<comment> \<open>guard\<close>
    synth (analz (insert m (ik s))) \<inter> secret s = {} \<and>

    \<comment> \<open>action\<close>
    s' = s\<lparr>ik := insert m (ik s)\<rparr>
  }"

definition
  s0_trans :: "('a s0_state_scheme * 'a s0_state_scheme) set"
where
  "s0_trans \<equiv> (\<Union>m. s0_add_secret m) \<union> (\<Union>m. s0_learn m) \<union> Id"

text \<open>Initial state is any state satisfying the invariant. The whole state is
observable. Put all together to define the L0 specification.\<close>

definition
  s0_init :: "'a s0_state_scheme set"
where
  "s0_init \<equiv> s0_secrecy"

type_synonym
  s0_obs = "s0_state"

definition
  s0 :: "(s0_state, s0_obs) spec" where
  "s0 \<equiv> \<lparr>
    init = s0_init,
    trans = s0_trans,
    obs = id
  \<rparr>"

lemmas s0_defs = s0_def s0_init_def s0_trans_def s0_add_secret_def s0_learn_def
lemmas s0_all_defs = s0_defs ik_trans_defs

lemma s0_obs_id [simp]: "obs s0 = id"
by (simp add: s0_def)

(**************************************************************************************************)
subsection \<open>Proof of secrecy invariant\<close>
(**************************************************************************************************)

lemma s0_secrecy_init [iff]: "init s0 \<subseteq> s0_secrecy"
by (simp add: s0_defs)

lemma s0_secrecy_trans [simp, intro]: "{s0_secrecy} trans s0 {> s0_secrecy}"
apply (auto simp add: s0_all_defs PO_hoare_defs intro!: s0_secrecyI)
apply (auto)
done

lemma s0_secrecy [iff]:"reach s0 \<subseteq> s0_secrecy"
by (rule inv_rule_basic, auto)

lemma s0_obs_secrecy [iff]:"oreach s0 \<subseteq> s0_secrecy"
by (rule external_from_internal_invariant) (auto del: subsetI)

end


theory hw06
  imports Main
begin

fun funky::"int \<Rightarrow> int" where
 "funky k = (k - 3)^2"

value "sort_key funky [(2::int), 1, 3, 4]"

find_theorems "insort_key"

lemma "[x\<leftarrow>sort_key k xs. k x = a] = [x\<leftarrow>xs. k x = a]"
  apply(induction xs)
   apply(auto simp: filter_insort_triv filter_insort insort_is_Cons)
  done

fun quickselect :: "'a::linorder list \<Rightarrow> nat \<Rightarrow> 'a" where
  "quickselect (x#xs) k = (let
    xs1 = [y\<leftarrow>xs. y<x];
    xs2 = [y\<leftarrow>xs. \<not>(y<x)]
  in
    if k<length xs1 then quickselect xs1 k
    else if k=length xs1 then x
    else quickselect xs2 (k-length xs1-1)
  )"
| "quickselect [] _ = undefined"

lemma aux1[simp]: "(\<forall>x\<in>set xs. x < p) \<Longrightarrow> (\<forall>y\<in>set ys. \<not> y < p) \<Longrightarrow> (a < p) \<Longrightarrow> insort a (xs@ys) = (insort a xs) @ ys"
  apply(induction xs)
  apply(induction ys)
  by auto

lemma aux2[simp]: "(\<forall>x\<in>set xs. x < p) \<Longrightarrow> (\<forall>y\<in>set ys. \<not> y < p) \<Longrightarrow> \<not>(a < p) \<Longrightarrow> insort a (xs@ys) = (xs) @ insort a ys"
  apply(induction xs)
  apply(induction ys)
  by auto

lemma partition_correct[simp]: "sort xs = sort [x\<leftarrow>xs. x<p] @ sort [x\<leftarrow>xs. \<not>(x<p)]"
  apply(induction xs)
  apply(simp)
   apply(clarsimp)
  apply(smt aux1 aux2 filter_set member_filter set_sort)
  done

lemma "k<length xs \<Longrightarrow> quickselect xs k = sort xs ! k"
proof (induction xs k rule: quickselect.induct)
  print_cases
  case (1 x xs k)
  note IH = "1.IH"[OF refl refl]

  let ?xs1 = "[y\<leftarrow>xs. y<x]"

  show ?case proof cases
    assume "k<length ?xs1" then show ?thesis apply (simp add: IH) sorry
  next
    assume "\<not>(k<length ?xs1)" then show ?thesis sorry

  qed
next
  case 2 then show ?case by simp
qed

end