(* Title:      Algebras for Aggregation and Minimisation with a Linear Order
   Author:     Walter Guttmann
   Maintainer: Walter Guttmann <walter.guttmann at canterbury.ac.nz>
*)

section \<open>Algebras for Aggregation and Minimisation with a Linear Order\<close>

text \<open>
This theory gives several classes of instances of linear aggregation lattices as described in \<^cite>\<open>"Guttmann2018a"\<close>.
Each of these instances can be used as edge weights and the resulting graphs will form s-algebras and m-algebras as shown in a separate theory.
\<close>

theory Linear_Aggregation_Algebras

imports Matrix_Aggregation_Algebras HOL.Real

begin

no_notation
  inf (infixl "\<sqinter>" 70)
  and uminus ("- _" [81] 80)

subsection \<open>Linearly Ordered Commutative Semigroups\<close>

text \<open>
Any linearly ordered commutative semigroup extended by new least and greatest elements forms a linear aggregation lattice.
The extension is done so that the new least element is a unit of aggregation and the new greatest element is a zero of aggregation.
\<close>

datatype 'a ext =
    Bot
  | Val 'a
  | Top

instantiation ext :: (linordered_ab_semigroup_add) linear_aggregation_kleene_algebra
begin

fun plus_ext :: "'a ext \<Rightarrow> 'a ext \<Rightarrow> 'a ext" where
  "plus_ext Bot x = x"
| "plus_ext (Val x) Bot = Val x"
| "plus_ext (Val x) (Val y) = Val (x + y)"
| "plus_ext (Val _) Top = Top"
| "plus_ext Top _ = Top"

fun sup_ext :: "'a ext \<Rightarrow> 'a ext \<Rightarrow> 'a ext" where
  "sup_ext Bot x = x"
| "sup_ext (Val x) Bot = Val x"
| "sup_ext (Val x) (Val y) = Val (max x y)"
| "sup_ext (Val _) Top = Top"
| "sup_ext Top _ = Top"

fun inf_ext :: "'a ext \<Rightarrow> 'a ext \<Rightarrow> 'a ext" where
  "inf_ext Bot _ = Bot"
| "inf_ext (Val _) Bot = Bot"
| "inf_ext (Val x) (Val y) = Val (min x y)"
| "inf_ext (Val x) Top = Val x"
| "inf_ext Top x = x"

fun times_ext :: "'a ext \<Rightarrow> 'a ext \<Rightarrow> 'a ext" where "times_ext x y = x \<sqinter> y"

fun uminus_ext :: "'a ext \<Rightarrow> 'a ext" where
  "uminus_ext Bot = Top"
| "uminus_ext (Val _) = Bot"
| "uminus_ext Top = Bot"

fun star_ext :: "'a ext \<Rightarrow> 'a ext" where "star_ext _ = Top"

fun conv_ext :: "'a ext \<Rightarrow> 'a ext" where "conv_ext x = x"

definition bot_ext :: "'a ext" where "bot_ext \<equiv> Bot"
definition one_ext :: "'a ext" where "one_ext \<equiv> Top"
definition top_ext :: "'a ext" where "top_ext \<equiv> Top"

fun less_eq_ext :: "'a ext \<Rightarrow> 'a ext \<Rightarrow> bool" where
  "less_eq_ext Bot _ = True"
| "less_eq_ext (Val _) Bot = False"
| "less_eq_ext (Val x) (Val y) = (x \<le> y)"
| "less_eq_ext (Val _) Top = True"
| "less_eq_ext Top Bot = False"
| "less_eq_ext Top (Val _) = False"
| "less_eq_ext Top Top = True"

fun less_ext :: "'a ext \<Rightarrow> 'a ext \<Rightarrow> bool" where "less_ext x y = (x \<le> y \<and> \<not> y \<le> x)"

instance
proof
  fix x y z :: "'a ext"
  show "(x + y) + z = x + (y + z)"
    by (cases x; cases y; cases z) (simp_all add: add.assoc)
  show "x + y = y + x"
    by (cases x; cases y) (simp_all add: add.commute)
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by simp
  show "x \<le> x"
    using less_eq_ext.elims(3) by fastforce
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> x"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> y"
    by (cases x; cases y) simp_all
  show "x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
    by (cases x; cases y; cases z) simp_all
  show "bot \<le> x"
    by (simp add: bot_ext_def)
  show "x \<le> top"
    by (cases x) (simp_all add: top_ext_def)
  show "x \<noteq> bot \<and> x + bot \<le> y + bot \<longrightarrow> x + z \<le> y + z"
    by (cases x; cases y; cases z) (simp_all add: bot_ext_def add_right_mono)
  show "x + y + bot = x + y"
    by (cases x; cases y) (simp_all add: bot_ext_def)
  show "x + y = bot \<longrightarrow> x = bot"
    by (cases x; cases y) (simp_all add: bot_ext_def)
  show "x \<le> y \<or> y \<le> x"
    by (cases x; cases y) (simp_all add: linear)
  show "-x = (if x = bot then top else bot)"
    by (cases x) (simp_all add: bot_ext_def top_ext_def)
  show "(1::'a ext) = top"
    by (simp add: one_ext_def top_ext_def)
  show "x * y = x \<sqinter> y"
    by simp
  show "x\<^sup>T = x"
    by simp
  show "x\<^sup>\<star> = top"
    by (simp add: top_ext_def)
qed

end

text \<open>
An example of a linearly ordered commutative semigroup is the set of real numbers with standard addition as aggregation.
\<close>

lemma example_real_ext_matrix:
  fixes x :: "('a::enum,real ext) square"
  shows "minarc\<^sub>M x \<preceq> \<ominus>\<ominus>x"
  by (rule agg_square_m_algebra.minarc_below)

text \<open>
Another example of a linearly ordered commutative semigroup is the set of real numbers with maximum as aggregation.
\<close>

datatype real_max = Rmax real

instantiation real_max :: linordered_ab_semigroup_add
begin

fun less_eq_real_max where "less_eq_real_max (Rmax x) (Rmax y) = (x \<le> y)"
fun less_real_max where "less_real_max (Rmax x) (Rmax y) = (x < y)"
fun plus_real_max where "plus_real_max (Rmax x) (Rmax y) = Rmax (max x y)"

instance
proof
  fix x y z :: real_max
  show "(x + y) + z = x + (y + z)"
    by (cases x; cases y; cases z) simp
  show "x + y = y + x"
    by (cases x; cases y) simp
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by (cases x; cases y) auto
  show "x \<le> x"
    by (cases x) simp
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (cases x; cases y; cases z) simp
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x; cases y) simp
  show "x \<le> y \<Longrightarrow> z + x \<le> z + y"
    by (cases x; cases y; cases z) simp
  show "x \<le> y \<or> y \<le> x"
    by (cases x; cases y) auto
qed

end

lemma example_real_max_ext_matrix:
  fixes x :: "('a::enum,real_max ext) square"
  shows "minarc\<^sub>M x \<preceq> \<ominus>\<ominus>x"
  by (rule agg_square_m_algebra.minarc_below)

text \<open>
A third example of a linearly ordered commutative semigroup is the set of real numbers with minimum as aggregation.
\<close>

datatype real_min = Rmin real

instantiation real_min :: linordered_ab_semigroup_add
begin

fun less_eq_real_min where "less_eq_real_min (Rmin x) (Rmin y) = (x \<le> y)"
fun less_real_min where "less_real_min (Rmin x) (Rmin y) = (x < y)"
fun plus_real_min where "plus_real_min (Rmin x) (Rmin y) = Rmin (min x y)"

instance
proof
  fix x y z :: real_min
  show "(x + y) + z = x + (y + z)"
    by (cases x; cases y; cases z) simp
  show "x + y = y + x"
    by (cases x; cases y) simp
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by (cases x; cases y) auto
  show "x \<le> x"
    by (cases x) simp
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (cases x; cases y; cases z) simp
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x; cases y) simp
  show "x \<le> y \<Longrightarrow> z + x \<le> z + y"
    by (cases x; cases y; cases z) simp
  show "x \<le> y \<or> y \<le> x"
    by (cases x; cases y) auto
qed

end

lemma example_real_min_ext_matrix:
  fixes x :: "('a::enum,real_min ext) square"
  shows "minarc\<^sub>M x \<preceq> \<ominus>\<ominus>x"
  by (rule agg_square_m_algebra.minarc_below)

subsection \<open>Linearly Ordered Commutative Monoids\<close>

text \<open>
Any linearly ordered commutative monoid extended by new least and greatest elements forms a linear aggregation lattice.
This is similar to linearly ordered commutative semigroups except that the aggregation $\bot + \bot$ produces the unit of the monoid instead of the least element.
Applied to weighted graphs, this means that the aggregation of the empty graph will be the unit of the monoid (for example, $0$ for real numbers under standard addition, instead of $\bot$).
\<close>

class linordered_comm_monoid_add = linordered_ab_semigroup_add + comm_monoid_add

datatype 'a ext0 =
    Bot
  | Val 'a
  | Top

instantiation ext0 :: (linordered_comm_monoid_add) linear_aggregation_kleene_algebra
begin

fun plus_ext0 :: "'a ext0 \<Rightarrow> 'a ext0 \<Rightarrow> 'a ext0" where
  "plus_ext0 Bot Bot = Val 0"
| "plus_ext0 Bot x = x"
| "plus_ext0 (Val x) Bot = Val x"
| "plus_ext0 (Val x) (Val y) = Val (x + y)"
| "plus_ext0 (Val _) Top = Top"
| "plus_ext0 Top _ = Top"

fun sup_ext0 :: "'a ext0 \<Rightarrow> 'a ext0 \<Rightarrow> 'a ext0" where
  "sup_ext0 Bot x = x"
| "sup_ext0 (Val x) Bot = Val x"
| "sup_ext0 (Val x) (Val y) = Val (max x y)"
| "sup_ext0 (Val _) Top = Top"
| "sup_ext0 Top _ = Top"

fun inf_ext0 :: "'a ext0 \<Rightarrow> 'a ext0 \<Rightarrow> 'a ext0" where
  "inf_ext0 Bot _ = Bot"
| "inf_ext0 (Val _) Bot = Bot"
| "inf_ext0 (Val x) (Val y) = Val (min x y)"
| "inf_ext0 (Val x) Top = Val x"
| "inf_ext0 Top x = x"

fun times_ext0 :: "'a ext0 \<Rightarrow> 'a ext0 \<Rightarrow> 'a ext0" where "times_ext0 x y = x \<sqinter> y"

fun uminus_ext0 :: "'a ext0 \<Rightarrow> 'a ext0" where
  "uminus_ext0 Bot = Top"
| "uminus_ext0 (Val _) = Bot"
| "uminus_ext0 Top = Bot"

fun star_ext0 :: "'a ext0 \<Rightarrow> 'a ext0" where "star_ext0 _ = Top"

fun conv_ext0 :: "'a ext0 \<Rightarrow> 'a ext0" where "conv_ext0 x = x"

definition bot_ext0 :: "'a ext0" where "bot_ext0 \<equiv> Bot"
definition one_ext0 :: "'a ext0" where "one_ext0 \<equiv> Top"
definition top_ext0 :: "'a ext0" where "top_ext0 \<equiv> Top"

fun less_eq_ext0 :: "'a ext0 \<Rightarrow> 'a ext0 \<Rightarrow> bool" where
  "less_eq_ext0 Bot _ = True"
| "less_eq_ext0 (Val _) Bot = False"
| "less_eq_ext0 (Val x) (Val y) = (x \<le> y)"
| "less_eq_ext0 (Val _) Top = True"
| "less_eq_ext0 Top Bot = False"
| "less_eq_ext0 Top (Val _) = False"
| "less_eq_ext0 Top Top = True"

fun less_ext0 :: "'a ext0 \<Rightarrow> 'a ext0 \<Rightarrow> bool" where "less_ext0 x y = (x \<le> y \<and> \<not> y \<le> x)"

instance
proof
  fix x y z :: "'a ext0"
  show "(x + y) + z = x + (y + z)"
    by (cases x; cases y; cases z) (simp_all add: add.assoc)
  show "x + y = y + x"
    by (cases x; cases y) (simp_all add: add.commute)
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by simp
  show "x \<le> x"
    using less_eq_ext0.elims(3) by fastforce
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> x"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> y"
    by (cases x; cases y) simp_all
  show "x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
    by (cases x; cases y; cases z) simp_all
  show "bot \<le> x"
    by (simp add: bot_ext0_def)
  show "x \<le> top"
    by (cases x) (simp_all add: top_ext0_def)
  show "x \<noteq> bot \<and> x + bot \<le> y + bot \<longrightarrow> x + z \<le> y + z"
    apply (cases x; cases y; cases z)
    prefer 11 using add_right_mono bot_ext0_def apply fastforce
    by (simp_all add: bot_ext0_def add_right_mono)
  show "x + y + bot = x + y"
    by (cases x; cases y) (simp_all add: bot_ext0_def)
  show "x + y = bot \<longrightarrow> x = bot"
    by (cases x; cases y) (simp_all add: bot_ext0_def)
  show "x \<le> y \<or> y \<le> x"
    by (cases x; cases y) (simp_all add: linear)
  show "-x = (if x = bot then top else bot)"
    by (cases x) (simp_all add: bot_ext0_def top_ext0_def)
  show "(1::'a ext0) = top"
    by (simp add: one_ext0_def top_ext0_def)
  show "x * y = x \<sqinter> y"
    by simp
  show "x\<^sup>T = x"
    by simp
  show "x\<^sup>\<star> = top"
    by (simp add: top_ext0_def)
qed

end

text \<open>
An example of a linearly ordered commutative monoid is the set of real numbers with standard addition and unit $0$.
\<close>

instantiation real :: linordered_comm_monoid_add
begin

instance ..

end

subsection \<open>Linearly Ordered Commutative Monoids with a Least Element\<close>

text \<open>
If a linearly ordered commutative monoid already contains a least element which is a unit of aggregation, only a new greatest element has to be added to obtain a linear aggregation lattice.
\<close>

class linordered_comm_monoid_add_bot = linordered_ab_semigroup_add + order_bot +
  assumes bot_zero [simp]: "bot + x = x"
begin

sublocale linordered_comm_monoid_add where zero = bot
  apply unfold_locales
  by simp

end

datatype 'a extT =
    Val 'a
  | Top

instantiation extT :: (linordered_comm_monoid_add_bot) linear_aggregation_kleene_algebra
begin

fun plus_extT :: "'a extT \<Rightarrow> 'a extT \<Rightarrow> 'a extT" where
  "plus_extT (Val x) (Val y) = Val (x + y)"
| "plus_extT (Val _) Top = Top"
| "plus_extT Top _ = Top"

fun sup_extT :: "'a extT \<Rightarrow> 'a extT \<Rightarrow> 'a extT" where
  "sup_extT (Val x) (Val y) = Val (max x y)"
| "sup_extT (Val _) Top = Top"
| "sup_extT Top _ = Top"

fun inf_extT :: "'a extT \<Rightarrow> 'a extT \<Rightarrow> 'a extT" where
  "inf_extT (Val x) (Val y) = Val (min x y)"
| "inf_extT (Val x) Top = Val x"
| "inf_extT Top x = x"

fun times_extT :: "'a extT \<Rightarrow> 'a extT \<Rightarrow> 'a extT" where "times_extT x y = x \<sqinter> y"

fun uminus_extT :: "'a extT \<Rightarrow> 'a extT" where "uminus_extT x = (if x = Val bot then Top else Val bot)"

fun star_extT :: "'a extT \<Rightarrow> 'a extT" where "star_extT _ = Top"

fun conv_extT :: "'a extT \<Rightarrow> 'a extT" where "conv_extT x = x"

definition bot_extT :: "'a extT" where "bot_extT \<equiv> Val bot"
definition one_extT :: "'a extT" where "one_extT \<equiv> Top"
definition top_extT :: "'a extT" where "top_extT \<equiv> Top"

fun less_eq_extT :: "'a extT \<Rightarrow> 'a extT \<Rightarrow> bool" where
  "less_eq_extT (Val x) (Val y) = (x \<le> y)"
| "less_eq_extT Top (Val _) = False"
| "less_eq_extT _ Top = True"

fun less_extT :: "'a extT \<Rightarrow> 'a extT \<Rightarrow> bool" where "less_extT x y = (x \<le> y \<and> \<not> y \<le> x)"

instance
proof
  fix x y z :: "'a extT"
  show "(x + y) + z = x + (y + z)"
    by (cases x; cases y; cases z) (simp_all add: add.assoc)
  show "x + y = y + x"
    by (cases x; cases y) (simp_all add: add.commute)
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by simp
  show "x \<le> x"
    by (cases x) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> x"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> y"
    by (cases x; cases y) simp_all
  show "x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
    by (cases x; cases y; cases z) simp_all
  show "bot \<le> x"
    by (cases x) (simp_all add: bot_extT_def)
  show "x \<le> top"
    by (cases x) (simp_all add: top_extT_def)
  show "x \<noteq> bot \<and> x + bot \<le> y + bot \<longrightarrow> x + z \<le> y + z"
    by (cases x; cases y; cases z) (simp_all add: bot_extT_def add_right_mono)
  show "x + y + bot = x + y"
    by (cases x; cases y) (simp_all add: bot_extT_def)
  show "x + y = bot \<longrightarrow> x = bot"
    apply (cases x; cases y)
    apply (metis (mono_tags) add.commute add_right_mono bot.extremum bot.extremum_uniqueI bot_zero extT.inject plus_extT.simps(1) bot_extT_def)
    by (simp_all add: bot_extT_def)
  show "x \<le> y \<or> y \<le> x"
    by (cases x; cases y) (simp_all add: linear)
  show "-x = (if x = bot then top else bot)"
    by (cases x) (simp_all add: bot_extT_def top_extT_def)
  show "(1::'a extT) = top"
    by (simp add: one_extT_def top_extT_def)
  show "x * y = x \<sqinter> y"
    by simp
  show "x\<^sup>T = x"
    by simp
  show "x\<^sup>\<star> = top"
    by (simp add: top_extT_def)
qed

end

text \<open>
An example of a linearly ordered commutative monoid with a least element is the set of real numbers extended by minus infinity with maximum as aggregation.
\<close>

datatype real_max_bot =
    MInfty
  | R real

instantiation real_max_bot :: linordered_comm_monoid_add_bot
begin

definition "bot_real_max_bot \<equiv> MInfty"

fun less_eq_real_max_bot where
  "less_eq_real_max_bot MInfty _ = True"
| "less_eq_real_max_bot (R _) MInfty = False"
| "less_eq_real_max_bot (R x) (R y) = (x \<le> y)"

fun less_real_max_bot where
  "less_real_max_bot _ MInfty = False"
| "less_real_max_bot MInfty (R _) = True"
| "less_real_max_bot (R x) (R y) = (x < y)"

fun plus_real_max_bot where
  "plus_real_max_bot MInfty y = y"
| "plus_real_max_bot x MInfty = x"
| "plus_real_max_bot (R x) (R y) = R (max x y)"

instance
proof
  fix x y z :: real_max_bot
  show "(x + y) + z = x + (y + z)"
    by (cases x; cases y; cases z) simp_all
  show "x + y = y + x"
    by (cases x; cases y) simp_all
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by (cases x; cases y) auto
  show "x \<le> x"
    by (cases x) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x; cases y) simp_all
  show "x \<le> y \<Longrightarrow> z + x \<le> z + y"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> y \<or> y \<le> x"
    by (cases x; cases y) auto
  show "bot \<le> x"
    by (cases x) (simp_all add: bot_real_max_bot_def)
  show "bot + x = x"
    by (cases x) (simp_all add: bot_real_max_bot_def)
qed

end

subsection \<open>Linearly Ordered Commutative Monoids with a Greatest Element\<close>

text \<open>
If a linearly ordered commutative monoid already contains a greatest element which is a unit of aggregation, only a new least element has to be added to obtain a linear aggregation lattice.
\<close>

class linordered_comm_monoid_add_top = linordered_ab_semigroup_add + order_top +
  assumes top_zero [simp]: "top + x = x"
begin

sublocale linordered_comm_monoid_add where zero = top
  apply unfold_locales
  by simp

lemma add_decreasing: "x + y \<le> x"
  using add_left_mono top.extremum by fastforce

end

datatype 'a extB =
    Bot
  | Val 'a

instantiation extB :: (linordered_comm_monoid_add_top) linear_aggregation_kleene_algebra
begin

fun plus_extB :: "'a extB \<Rightarrow> 'a extB \<Rightarrow> 'a extB" where
  "plus_extB Bot Bot = Val top"
| "plus_extB Bot (Val x) = Val x"
| "plus_extB (Val x) Bot = Val x"
| "plus_extB (Val x) (Val y) = Val (x + y)"

fun sup_extB :: "'a extB \<Rightarrow> 'a extB \<Rightarrow> 'a extB" where
  "sup_extB Bot x = x"
| "sup_extB (Val x) Bot = Val x"
| "sup_extB (Val x) (Val y) = Val (max x y)"

fun inf_extB :: "'a extB \<Rightarrow> 'a extB \<Rightarrow> 'a extB" where
  "inf_extB Bot _ = Bot"
| "inf_extB (Val _) Bot = Bot"
| "inf_extB (Val x) (Val y) = Val (min x y)"

fun times_extB :: "'a extB \<Rightarrow> 'a extB \<Rightarrow> 'a extB" where "times_extB x y = x \<sqinter> y"

fun uminus_extB :: "'a extB \<Rightarrow> 'a extB" where
  "uminus_extB Bot = Val top"
| "uminus_extB (Val _) = Bot"

fun star_extB :: "'a extB \<Rightarrow> 'a extB" where "star_extB _ = Val top"

fun conv_extB :: "'a extB \<Rightarrow> 'a extB" where "conv_extB x = x"

definition bot_extB :: "'a extB" where "bot_extB \<equiv> Bot"
definition one_extB :: "'a extB" where "one_extB \<equiv> Val top"
definition top_extB :: "'a extB" where "top_extB \<equiv> Val top"

fun less_eq_extB :: "'a extB \<Rightarrow> 'a extB \<Rightarrow> bool" where
  "less_eq_extB Bot _ = True"
| "less_eq_extB (Val _) Bot = False"
| "less_eq_extB (Val x) (Val y) = (x \<le> y)"

fun less_extB :: "'a extB \<Rightarrow> 'a extB \<Rightarrow> bool" where "less_extB x y = (x \<le> y \<and> \<not> y \<le> x)"

instance
proof
  fix x y z :: "'a extB"
  show "(x + y) + z = x + (y + z)"
    by (cases x; cases y; cases z) (simp_all add: add.assoc)
  show "x + y = y + x"
    by (cases x; cases y) (simp_all add: add.commute)
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by simp
  show "x \<le> x"
    by (cases x) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> x"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> y"
    by (cases x; cases y) simp_all
  show "x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
    by (cases x; cases y; cases z) simp_all
  show "bot \<le> x"
    by (simp add: bot_extB_def)
  show 1: "x \<le> top"
    by (cases x) (simp_all add: top_extB_def)
  show "x \<noteq> bot \<and> x + bot \<le> y + bot \<longrightarrow> x + z \<le> y + z"
    apply (cases x; cases y; cases z)
    prefer 6 using 1 apply (metis (mono_tags, lifting) plus_extB.simps(2,4) top_extB_def add_right_mono less_eq_extB.simps(3) top_zero)
    by (simp_all add: bot_extB_def add_right_mono)
  show "x + y + bot = x + y"
    by (cases x; cases y) (simp_all add: bot_extB_def)
  show "x + y = bot \<longrightarrow> x = bot"
    by (cases x; cases y) (simp_all add: bot_extB_def)
  show "x \<le> y \<or> y \<le> x"
    by (cases x; cases y) (simp_all add: linear)
  show "-x = (if x = bot then top else bot)"
    by (cases x) (simp_all add: bot_extB_def top_extB_def)
  show "(1::'a extB) = top"
    by (simp add: one_extB_def top_extB_def)
  show "x * y = x \<sqinter> y"
    by simp
  show "x\<^sup>T = x"
    by simp
  show "x\<^sup>\<star> = top"
    by (simp add: top_extB_def)
qed

end

text \<open>
An example of a linearly ordered commutative monoid with a greatest element is the set of real numbers extended by infinity with minimum as aggregation.
\<close>

datatype real_min_top =
    R real
  | PInfty

instantiation real_min_top :: linordered_comm_monoid_add_top
begin

definition "top_real_min_top \<equiv> PInfty"

fun less_eq_real_min_top where
  "less_eq_real_min_top _ PInfty = True"
| "less_eq_real_min_top PInfty (R _) = False"
| "less_eq_real_min_top (R x) (R y) = (x \<le> y)"

fun less_real_min_top where
  "less_real_min_top PInfty _ = False"
| "less_real_min_top (R _) PInfty = True"
| "less_real_min_top (R x) (R y) = (x < y)"

fun plus_real_min_top where
  "plus_real_min_top PInfty y = y"
| "plus_real_min_top x PInfty = x"
| "plus_real_min_top (R x) (R y) = R (min x y)"

instance
proof
  fix x y z :: real_min_top
  show "(x + y) + z = x + (y + z)"
    by (cases x; cases y; cases z) simp_all
  show "x + y = y + x"
    by (cases x; cases y) simp_all
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by (cases x; cases y) auto
  show "x \<le> x"
    by (cases x) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x; cases y) simp_all
  show "x \<le> y \<Longrightarrow> z + x \<le> z + y"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> y \<or> y \<le> x"
    by (cases x; cases y) auto
  show "x \<le> top"
    by (cases x) (simp_all add: top_real_min_top_def)
  show "top + x = x"
    by (cases x) (simp_all add: top_real_min_top_def)
qed

end

text \<open>
Another example of a linearly ordered commutative monoid with a greatest element is the unit interval of real numbers with any triangular norm (t-norm) as aggregation.
Ideally, we would like to show that the unit interval is an instance of \<open>linordered_comm_monoid_add_top\<close>.
However, this class has an addition operation, so the instantiation would require dependent types.
We therefore show only the order property in general and a particular instance of the class.
\<close>

typedef (overloaded) unit = "{0..1} :: real set"
  by auto

setup_lifting type_definition_unit

instantiation unit :: bounded_linorder
begin

lift_definition bot_unit :: unit is 0
  by simp

lift_definition top_unit :: unit is 1
  by simp

lift_definition less_eq_unit :: "unit \<Rightarrow> unit \<Rightarrow> bool" is less_eq .

lift_definition less_unit :: "unit \<Rightarrow> unit \<Rightarrow> bool" is less .

instance
  apply intro_classes
  using bot_unit.rep_eq top_unit.rep_eq less_eq_unit.rep_eq less_unit.rep_eq unit.Rep_unit_inject unit.Rep_unit by auto

end

text \<open>
We give the \L{}ukasiewicz t-norm as a particular instance.
\<close>

instantiation unit :: linordered_comm_monoid_add_top
begin

abbreviation tl :: "real \<Rightarrow> real \<Rightarrow> real" where
  "tl x y \<equiv> max (x + y - 1) 0"

lemma tl_assoc:
  "x \<in> {0..1} \<Longrightarrow> z \<in> {0..1} \<Longrightarrow> tl (tl x y) z = tl x (tl y z)"
  by auto

lemma tl_top_zero:
  "x \<in> {0..1} \<Longrightarrow> tl 1 x = x"
  by auto

lift_definition plus_unit :: "unit \<Rightarrow> unit \<Rightarrow> unit" is tl
  by simp

instance
  apply intro_classes
  apply (metis (mono_tags, lifting) plus_unit.rep_eq unit.Rep_unit_inject unit.Rep_unit tl_assoc)
  using unit.Rep_unit_inject plus_unit.rep_eq apply fastforce
  apply (simp add: less_eq_unit.rep_eq plus_unit.rep_eq)
  by (metis (mono_tags, lifting) top_unit.rep_eq unit.Rep_unit_inject unit.Rep_unit plus_unit.rep_eq tl_top_zero)

end

subsection \<open>Linearly Ordered Commutative Monoids with a Least Element and a Greatest Element\<close>

text \<open>
If a linearly ordered commutative monoid already contains a least element which is a unit of aggregation and a greatest element, it forms a linear aggregation lattice.
\<close>

class linordered_bounded_comm_monoid_add_bot = linordered_comm_monoid_add_bot + order_top
begin

subclass bounded_linorder ..

subclass aggregation_order
  apply unfold_locales
  apply (simp add: add_right_mono)
  apply simp
  by (metis add_0_right add_left_mono bot.extremum bot.extremum_unique)

sublocale linear_aggregation_kleene_algebra where sup = max and inf = min and times = min and conv = id and one = top and star = "\<lambda>x . top" and uminus = "\<lambda>x . if x = bot then top else bot"
  apply unfold_locales
  by simp_all

lemma t_top: "x + top = top"
  by (metis add_right_mono bot.extremum bot_zero top_unique)

lemma add_increasing: "x \<le> x + y"
  using add_left_mono bot.extremum by fastforce

lemma t_max: "max x y \<le> x + y"
  using add_commute add_increasing by force

end

text \<open>
An example of a linearly ordered commutative monoid with a least and a greatest element is the unit interval of real numbers with any triangular conorm (t-conorm) as aggregation.
For the reason outlined above, we show just a particular instance of \<open>linordered_bounded_comm_monoid_add_bot\<close>.
Because the \<open>plus\<close> functions in the two instances given for the unit type are different, we work on a copy of the unit type.
\<close>

typedef (overloaded) unit2 = "{0..1} :: real set"
  by auto

setup_lifting type_definition_unit2

instantiation unit2 :: bounded_linorder
begin

lift_definition bot_unit2 :: unit2 is 0
  by simp

lift_definition top_unit2 :: unit2 is 1
  by simp

lift_definition less_eq_unit2 :: "unit2 \<Rightarrow> unit2 \<Rightarrow> bool" is less_eq .

lift_definition less_unit2 :: "unit2 \<Rightarrow> unit2 \<Rightarrow> bool" is less .

instance
  apply intro_classes
  using bot_unit2.rep_eq top_unit2.rep_eq less_eq_unit2.rep_eq less_unit2.rep_eq unit2.Rep_unit2_inject unit2.Rep_unit2 by auto

end

text \<open>
We give the product t-conorm as a particular instance.
\<close>

instantiation unit2 :: linordered_bounded_comm_monoid_add_bot
begin

abbreviation sp :: "real \<Rightarrow> real \<Rightarrow> real" where
  "sp x y \<equiv> x + y - x * y"

lemma sp_assoc:
  "sp (sp x y) z = sp x (sp y z)"
  by (unfold left_diff_distrib right_diff_distrib distrib_left distrib_right) simp

lemma sp_mono:
  assumes "z \<in> {0..1}"
      and "x \<le> y"
    shows "sp z x \<le> sp z y"
proof -
  have "z + (1 - z) * x \<le> z + (1 - z) * y"
    using assms mult_left_mono by fastforce
  thus ?thesis
    by (unfold left_diff_distrib right_diff_distrib distrib_left distrib_right) simp
qed

lift_definition plus_unit2 :: "unit2 \<Rightarrow> unit2 \<Rightarrow> unit2" is sp
proof -
  fix x y :: real
  assume 1: "x \<in> {0..1}"
  assume 2: "y \<in> {0..1}"
  have "x - x * y \<le> 1 - y"
    using 1 2 by (metis (full_types) atLeastAtMost_iff diff_ge_0_iff_ge left_diff_distrib' mult.commute mult.left_neutral mult_left_le)
  hence 3: "x + y - x * y \<le> 1"
    by simp
  have "y * (x - 1) \<le> 0"
    using 1 2 by (meson atLeastAtMost_iff le_iff_diff_le_0 mult_nonneg_nonpos)
  hence "x + y - x * y \<ge> 0"
    using 1 by (metis (no_types) atLeastAtMost_iff diff_diff_eq2 diff_ge_0_iff_ge left_diff_distrib mult.commute mult.left_neutral order_trans)
  thus "x + y - x * y \<in> {0..1}"
    using 3 by simp
qed

instance
  apply intro_classes
  apply (metis (mono_tags, lifting) plus_unit2.rep_eq unit2.Rep_unit2_inject sp_assoc)
  using unit2.Rep_unit2_inject plus_unit2.rep_eq apply fastforce
  using sp_mono unit2.Rep_unit2 less_eq_unit2.rep_eq plus_unit2.rep_eq apply simp
  using bot_unit2.rep_eq unit2.Rep_unit2_inject plus_unit2.rep_eq by fastforce

end

subsection \<open>Constant Aggregation\<close>

text \<open>
Any linear order with a constant element extended by new least and greatest elements forms a linear aggregation lattice where the aggregation returns the given constant.
\<close>

class pointed_linorder = linorder +
  fixes const :: 'a

datatype 'a extC =
    Bot
  | Val 'a
  | Top

instantiation extC :: (pointed_linorder) linear_aggregation_kleene_algebra
begin

fun plus_extC :: "'a extC \<Rightarrow> 'a extC \<Rightarrow> 'a extC" where "plus_extC x y = Val const"

fun sup_extC :: "'a extC \<Rightarrow> 'a extC \<Rightarrow> 'a extC" where
  "sup_extC Bot x = x"
| "sup_extC (Val x) Bot = Val x"
| "sup_extC (Val x) (Val y) = Val (max x y)"
| "sup_extC (Val _) Top = Top"
| "sup_extC Top _ = Top"

fun inf_extC :: "'a extC \<Rightarrow> 'a extC \<Rightarrow> 'a extC" where
  "inf_extC Bot _ = Bot"
| "inf_extC (Val _) Bot = Bot"
| "inf_extC (Val x) (Val y) = Val (min x y)"
| "inf_extC (Val x) Top = Val x"
| "inf_extC Top x = x"

fun times_extC :: "'a extC \<Rightarrow> 'a extC \<Rightarrow> 'a extC" where "times_extC x y = x \<sqinter> y"

fun uminus_extC :: "'a extC \<Rightarrow> 'a extC" where
  "uminus_extC Bot = Top"
| "uminus_extC (Val _) = Bot"
| "uminus_extC Top = Bot"

fun star_extC :: "'a extC \<Rightarrow> 'a extC" where "star_extC _ = Top"

fun conv_extC :: "'a extC \<Rightarrow> 'a extC" where "conv_extC x = x"

definition bot_extC :: "'a extC" where "bot_extC \<equiv> Bot"
definition one_extC :: "'a extC" where "one_extC \<equiv> Top"
definition top_extC :: "'a extC" where "top_extC \<equiv> Top"

fun less_eq_extC :: "'a extC \<Rightarrow> 'a extC \<Rightarrow> bool" where
  "less_eq_extC Bot _ = True"
| "less_eq_extC (Val _) Bot = False"
| "less_eq_extC (Val x) (Val y) = (x \<le> y)"
| "less_eq_extC (Val _) Top = True"
| "less_eq_extC Top Bot = False"
| "less_eq_extC Top (Val _) = False"
| "less_eq_extC Top Top = True"

fun less_extC :: "'a extC \<Rightarrow> 'a extC \<Rightarrow> bool" where "less_extC x y = (x \<le> y \<and> \<not> y \<le> x)"

instance
proof
  fix x y z :: "'a extC"
  show "(x + y) + z = x + (y + z)"
    by simp
  show "x + y = y + x"
    by simp
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by simp
  show "x \<le> x"
    by (cases x) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> x"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> y"
    by (cases x; cases y) simp_all
  show "x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
    by (cases x; cases y; cases z) simp_all
  show "bot \<le> x"
    by (simp add: bot_extC_def)
  show "x \<le> top"
    by (cases x) (simp_all add: top_extC_def)
  show "x \<noteq> bot \<and> x + bot \<le> y + bot \<longrightarrow> x + z \<le> y + z"
    by simp
  show "x + y + bot = x + y"
    by simp
  show "x + y = bot \<longrightarrow> x = bot"
    by (simp add: bot_extC_def)
  show "x \<le> y \<or> y \<le> x"
    by (cases x; cases y) (simp_all add: linear)
  show "-x = (if x = bot then top else bot)"
    by (cases x) (simp_all add: bot_extC_def top_extC_def)
  show "(1::'a extC) = top"
    by (simp add: one_extC_def top_extC_def)
  show "x * y = x \<sqinter> y"
    by simp
  show "x\<^sup>T = x"
    by simp
  show "x\<^sup>\<star> = top"
    by (simp add: top_extC_def)
qed

end

text \<open>
An example of a linear order is the set of real numbers.
Any real number can be chosen as the constant.
\<close>

instantiation real :: pointed_linorder
begin

instance ..

end

text \<open>
The following instance shows that any linear order with a constant forms a linearly ordered commutative semigroup with the alpha-median operation as aggregation.
The alpha-median of two elements is the median of these elements and the given constant.
\<close>

fun median3 :: "'a::ord \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> 'a" where
  "median3 x y z =
    (if x \<le> y \<and> y \<le> z then y else
     if x \<le> z \<and> z \<le> y then z else
     if y \<le> x \<and> x \<le> z then x else
     if y \<le> z \<and> z \<le> x then z else
     if z \<le> x \<and> x \<le> y then x else y)"

interpretation alpha_median: linordered_ab_semigroup_add where plus = "median3 const" and less_eq = less_eq and less = less
proof
  fix a b c :: 'a
  show "median3 const (median3 const a b) c = median3 const a (median3 const b c)"
    by (cases "const \<le> a"; cases "const \<le> b"; cases "const \<le> c"; cases "a \<le> b"; cases "a \<le> c"; cases "b \<le> c") auto
  show "median3 const a b = median3 const b a"
    by (cases "const \<le> a"; cases "const \<le> b"; cases "a \<le> b") auto
  assume "a \<le> b"
  thus "median3 const c a \<le> median3 const c b"
    by (cases "const \<le> a"; cases "const \<le> b"; cases "const \<le> c"; cases "a \<le> c"; cases "b \<le> c") auto
qed

subsection \<open>Counting Aggregation\<close>

text \<open>
Any linear order extended by new least and greatest elements and a copy of the natural numbers forms a linear aggregation lattice where the aggregation counts non-$\bot$ elements using the copy of the natural numbers.
\<close>

datatype 'a extN =
    Bot
  | Val 'a
  | N nat
  | Top

instantiation extN :: (linorder) linear_aggregation_kleene_algebra
begin

fun plus_extN :: "'a extN \<Rightarrow> 'a extN \<Rightarrow> 'a extN" where
  "plus_extN Bot Bot = N 0"
| "plus_extN Bot (Val _) = N 1"
| "plus_extN Bot (N y) = N y"
| "plus_extN Bot Top = N 1"
| "plus_extN (Val _) Bot = N 1"
| "plus_extN (Val _) (Val _) = N 2"
| "plus_extN (Val _) (N y) = N (y + 1)"
| "plus_extN (Val _) Top = N 2"
| "plus_extN (N x) Bot = N x"
| "plus_extN (N x) (Val _) = N (x + 1)"
| "plus_extN (N x) (N y) = N (x + y)"
| "plus_extN (N x) Top = N (x + 1)"
| "plus_extN Top Bot = N 1"
| "plus_extN Top (Val _) = N 2"
| "plus_extN Top (N y) = N (y + 1)"
| "plus_extN Top Top = N 2"

fun sup_extN :: "'a extN \<Rightarrow> 'a extN \<Rightarrow> 'a extN" where
  "sup_extN Bot x = x"
| "sup_extN (Val x) Bot = Val x"
| "sup_extN (Val x) (Val y) = Val (max x y)"
| "sup_extN (Val _) (N y) = N y"
| "sup_extN (Val _) Top = Top"
| "sup_extN (N x) Bot = N x"
| "sup_extN (N x) (Val _) = N x"
| "sup_extN (N x) (N y) = N (max x y)"
| "sup_extN (N _) Top = Top"
| "sup_extN Top _ = Top"

fun inf_extN :: "'a extN \<Rightarrow> 'a extN \<Rightarrow> 'a extN" where
  "inf_extN Bot _ = Bot"
| "inf_extN (Val _) Bot = Bot"
| "inf_extN (Val x) (Val y) = Val (min x y)"
| "inf_extN (Val x) (N _) = Val x"
| "inf_extN (Val x) Top = Val x"
| "inf_extN (N _) Bot = Bot"
| "inf_extN (N _) (Val y) = Val y"
| "inf_extN (N x) (N y) = N (min x y)"
| "inf_extN (N x) Top = N x"
| "inf_extN Top y = y"

fun times_extN :: "'a extN \<Rightarrow> 'a extN \<Rightarrow> 'a extN" where "times_extN x y = x \<sqinter> y"

fun uminus_extN :: "'a extN \<Rightarrow> 'a extN" where
  "uminus_extN Bot = Top"
| "uminus_extN (Val _) = Bot"
| "uminus_extN (N _) = Bot"
| "uminus_extN Top = Bot"

fun star_extN :: "'a extN \<Rightarrow> 'a extN" where "star_extN _ = Top"

fun conv_extN :: "'a extN \<Rightarrow> 'a extN" where "conv_extN x = x"

definition bot_extN :: "'a extN" where "bot_extN \<equiv> Bot"
definition one_extN :: "'a extN" where "one_extN \<equiv> Top"
definition top_extN :: "'a extN" where "top_extN \<equiv> Top"

fun less_eq_extN :: "'a extN \<Rightarrow> 'a extN \<Rightarrow> bool" where
  "less_eq_extN Bot _ = True"
| "less_eq_extN (Val _) Bot = False"
| "less_eq_extN (Val x) (Val y) = (x \<le> y)"
| "less_eq_extN (Val _) (N _) = True"
| "less_eq_extN (Val _) Top = True"
| "less_eq_extN (N _) Bot = False"
| "less_eq_extN (N _) (Val _) = False"
| "less_eq_extN (N x) (N y) = (x \<le> y)"
| "less_eq_extN (N _) Top = True"
| "less_eq_extN Top Bot = False"
| "less_eq_extN Top (Val _) = False"
| "less_eq_extN Top (N _) = False"
| "less_eq_extN Top Top = True"

fun less_extN :: "'a extN \<Rightarrow> 'a extN \<Rightarrow> bool" where "less_extN x y = (x \<le> y \<and> \<not> y \<le> x)"

instance
proof
  fix x y z :: "'a extN"
  show "(x + y) + z = x + (y + z)"
    by (cases x; cases y; cases z) simp_all
  show "x + y = y + x"
    by (cases x; cases y) simp_all
  show "(x < y) = (x \<le> y \<and> \<not> y \<le> x)"
    by simp
  show "x \<le> x"
    by (cases x) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> z \<Longrightarrow> x \<le> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> y \<Longrightarrow> y \<le> x \<Longrightarrow> x = y"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> x"
    by (cases x; cases y) simp_all
  show "x \<sqinter> y \<le> y"
    by (cases x; cases y) simp_all
  show "x \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> y \<sqinter> z"
    by (cases x; cases y; cases z) simp_all
  show "x \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<squnion> y"
    by (cases x; cases y) simp_all
  show "y \<le> x \<Longrightarrow> z \<le> x \<Longrightarrow> y \<squnion> z \<le> x"
    by (cases x; cases y; cases z) simp_all
  show "bot \<le> x"
    by (simp add: bot_extN_def)
  show "x \<le> top"
    by (cases x) (simp_all add: top_extN_def)
  show "x \<noteq> bot \<and> x + bot \<le> y + bot \<longrightarrow> x + z \<le> y + z"
    by (cases x; cases y; cases z) (simp_all add: bot_extN_def)
  show "x + y + bot = x + y"
    by (cases x; cases y) (simp_all add: bot_extN_def)
  show "x + y = bot \<longrightarrow> x = bot"
    by (cases x; cases y) (simp_all add: bot_extN_def)
  show "x \<le> y \<or> y \<le> x"
    by (cases x; cases y) (simp_all add: linear)
  show "-x = (if x = bot then top else bot)"
    by (cases x) (simp_all add: bot_extN_def top_extN_def)
  show "(1::'a extN) = top"
    by (simp add: one_extN_def top_extN_def)
  show "x * y = x \<sqinter> y"
    by simp
  show "x\<^sup>T = x"
    by simp
  show "x\<^sup>\<star> = top"
    by (simp add: top_extN_def)
qed

end

end


section \<open>Tensor products as matrices\<close>

theory Finite_Tensor_Product_Matrices
  imports Finite_Tensor_Product
begin

definition tensor_pack :: "nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat) \<Rightarrow> nat"
  where "tensor_pack X Y = (\<lambda>(x, y). x * Y + y)"

definition tensor_unpack :: "nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> (nat \<times> nat)"
  where "tensor_unpack X Y xy = (xy div Y, xy mod Y)"

lemma tensor_unpack_inj:
  assumes "i < A * B" and "j < A * B"
  shows "tensor_unpack A B i = tensor_unpack A B j \<longleftrightarrow> i = j"
  by (metis div_mult_mod_eq prod.sel(1) prod.sel(2) tensor_unpack_def)

lemma tensor_unpack_bound1[simp]: "i < A * B \<Longrightarrow> fst (tensor_unpack A B i) < A"
  unfolding tensor_unpack_def
  apply auto
  using less_mult_imp_div_less by blast
lemma tensor_unpack_bound2[simp]: "i < A * B \<Longrightarrow> snd (tensor_unpack A B i) < B"
  unfolding tensor_unpack_def
  apply auto
  by (metis mod_less_divisor mult.commute mult_zero_left nat_neq_iff not_less0)

lemma tensor_unpack_fstfst: \<open>fst (tensor_unpack A B (fst (tensor_unpack (A * B) C i)))
     = fst (tensor_unpack A (B * C) i)\<close>
  unfolding tensor_unpack_def apply auto
  by (metis div_mult2_eq mult.commute)
lemma tensor_unpack_sndsnd: \<open>snd (tensor_unpack B C (snd (tensor_unpack A (B * C) i)))
     = snd (tensor_unpack (A * B) C i)\<close>
  unfolding tensor_unpack_def apply auto
  by (meson dvd_triv_right mod_mod_cancel)
lemma tensor_unpack_fstsnd: \<open>fst (tensor_unpack B C (snd (tensor_unpack A (B * C) i)))
     = snd (tensor_unpack A B (fst (tensor_unpack (A * B) C i)))\<close>
  unfolding tensor_unpack_def apply auto
  by (metis (no_types, lifting) Euclidean_Division.div_eq_0_iff add_0_iff bits_mod_div_trivial div_mult_self4 mod_mult2_eq mod_mult_self1_is_0 mult.commute)

definition "tensor_state_jnf \<psi> \<phi> = (let d1 = dim_vec \<psi> in let d2 = dim_vec \<phi> in
  vec (d1*d2) (\<lambda>i. let (i1,i2) = tensor_unpack d1 d2 i in (vec_index \<psi> i1) * (vec_index \<phi> i2)))"

lemma tensor_state_jnf_dim[simp]: \<open>dim_vec (tensor_state_jnf \<psi> \<phi>) = dim_vec \<psi> * dim_vec \<phi>\<close>
  unfolding tensor_state_jnf_def Let_def by simp

lemma enum_prod_nth_tensor_unpack:
  assumes \<open>i < CARD('a) * CARD('b)\<close>
  shows "(Enum.enum ! i :: 'a::enum\<times>'b::enum) =
        (let (i1,i2) = tensor_unpack CARD('a) CARD('b) i in
              (Enum.enum ! i1, Enum.enum ! i2))"
  using assms
  by (simp add: enum_prod_def card_UNIV_length_enum product_nth tensor_unpack_def)

lemma vec_of_basis_enum_tensor_state_index:
  fixes \<psi> :: \<open>'a::enum ell2\<close> and \<phi> :: \<open>'b::enum ell2\<close>
  assumes [simp]: \<open>i < CARD('a) * CARD('b)\<close>
  shows \<open>vec_of_basis_enum (\<psi> \<otimes>\<^sub>s \<phi>) $ i = (let (i1,i2) = tensor_unpack CARD('a) CARD('b) i in
    vec_of_basis_enum \<psi> $ i1 * vec_of_basis_enum \<phi> $ i2)\<close>
proof -
  define i1 i2 where "i1 = fst (tensor_unpack CARD('a) CARD('b) i)"
    and "i2 = snd (tensor_unpack CARD('a) CARD('b) i)"
  have [simp]: "i1 < CARD('a)" "i2 < CARD('b)"
    using assms i1_def tensor_unpack_bound1 apply presburger
    using assms i2_def tensor_unpack_bound2 by presburger

  have \<open>vec_of_basis_enum (\<psi> \<otimes>\<^sub>s \<phi>) $ i = Rep_ell2 (\<psi> \<otimes>\<^sub>s \<phi>) (enum_class.enum ! i)\<close>
    by (simp add: vec_of_basis_enum_ell2_component)
  also have \<open>\<dots> = Rep_ell2 \<psi> (Enum.enum!i1) * Rep_ell2 \<phi> (Enum.enum!i2)\<close>
    apply (transfer fixing: i i1 i2)
    by (simp add: enum_prod_nth_tensor_unpack case_prod_beta i1_def i2_def)
  also have \<open>\<dots> = vec_of_basis_enum \<psi> $ i1 * vec_of_basis_enum \<phi> $ i2\<close>
    by (simp add: vec_of_basis_enum_ell2_component)
  finally show ?thesis
    by (simp add: case_prod_beta i1_def i2_def)
qed

lemma vec_of_basis_enum_tensor_state:
  fixes \<psi> :: \<open>'a::enum ell2\<close> and \<phi> :: \<open>'b::enum ell2\<close>
  shows \<open>vec_of_basis_enum (\<psi> \<otimes>\<^sub>s \<phi>) = tensor_state_jnf (vec_of_basis_enum \<psi>) (vec_of_basis_enum \<phi>)\<close>
  apply (rule eq_vecI, simp_all)
  apply (subst vec_of_basis_enum_tensor_state_index, simp_all)
  by (simp add: tensor_state_jnf_def case_prod_beta Let_def)

lemma mat_of_cblinfun_tensor_op_index:
  fixes a :: \<open>'a::enum ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b::enum ell2\<close> and b :: \<open>'c::enum ell2 \<Rightarrow>\<^sub>C\<^sub>L 'd::enum ell2\<close>
  assumes [simp]: \<open>i < CARD('b) * CARD('d)\<close>
  assumes [simp]: \<open>j < CARD('a) * CARD('c)\<close>
  shows \<open>mat_of_cblinfun (tensor_op a b) $$ (i,j) =
            (let (i1,i2) = tensor_unpack CARD('b) CARD('d) i in
             let (j1,j2) = tensor_unpack CARD('a) CARD('c) j in
                  mat_of_cblinfun a $$ (i1,j1) * mat_of_cblinfun b $$ (i2,j2))\<close>
proof -
  define i1 i2 j1 j2
    where "i1 = fst (tensor_unpack CARD('b) CARD('d) i)"
      and "i2 = snd (tensor_unpack CARD('b) CARD('d) i)"
      and "j1 = fst (tensor_unpack CARD('a) CARD('c) j)"
      and "j2 = snd (tensor_unpack CARD('a) CARD('c) j)"
  have [simp]: "i1 < CARD('b)" "i2 < CARD('d)" "j1 < CARD('a)" "j2 < CARD('c)"
    using assms i1_def tensor_unpack_bound1 apply presburger
    using assms i2_def tensor_unpack_bound2 apply blast
    using assms(2) j1_def tensor_unpack_bound1 apply blast
    using assms(2) j2_def tensor_unpack_bound2 by presburger

  have \<open>mat_of_cblinfun (tensor_op a b) $$ (i,j)
       = Rep_ell2 (tensor_op a b *\<^sub>V ket (Enum.enum!j)) (Enum.enum ! i)\<close>
    by (simp add: mat_of_cblinfun_ell2_component)
  also have \<open>\<dots> = Rep_ell2 ((a *\<^sub>V ket (Enum.enum!j1)) \<otimes>\<^sub>s (b *\<^sub>V ket (Enum.enum!j2))) (Enum.enum!i)\<close>
    by (simp add: tensor_op_ell2 enum_prod_nth_tensor_unpack[where i=j] Let_def case_prod_beta j1_def[symmetric] j2_def[symmetric] flip: tensor_ell2_ket)
  also have \<open>\<dots> = vec_of_basis_enum ((a *\<^sub>V ket (Enum.enum!j1)) \<otimes>\<^sub>s b *\<^sub>V ket (Enum.enum!j2)) $ i\<close>
    by (simp add: vec_of_basis_enum_ell2_component)
  also have \<open>\<dots> = vec_of_basis_enum (a *\<^sub>V ket (enum_class.enum ! j1)) $ i1 *
                  vec_of_basis_enum (b *\<^sub>V ket (enum_class.enum ! j2)) $ i2\<close>
    by (simp add: case_prod_beta vec_of_basis_enum_tensor_state_index i1_def[symmetric] i2_def[symmetric])
  also have \<open>\<dots> = Rep_ell2 (a *\<^sub>V ket (enum_class.enum ! j1)) (enum_class.enum ! i1) *
                  Rep_ell2 (b *\<^sub>V ket (enum_class.enum ! j2)) (enum_class.enum ! i2)\<close>
    by (simp add: vec_of_basis_enum_ell2_component)
  also have \<open>\<dots> = mat_of_cblinfun a $$ (i1, j1) * mat_of_cblinfun b $$ (i2, j2)\<close>
    by (simp add: mat_of_cblinfun_ell2_component)
  finally show ?thesis
    by (simp add: i1_def[symmetric] i2_def[symmetric] j1_def[symmetric] j2_def[symmetric] case_prod_beta)
qed

definition "tensor_op_jnf A B =
  (let r1 = dim_row A in
   let c1 = dim_col A in
   let r2 = dim_row B in
   let c2 = dim_col B in
   mat (r1*r2) (c1*c2)
   (\<lambda>(i,j). let (i1,i2) = tensor_unpack r1 r2 i in
            let (j1,j2) = tensor_unpack c1 c2 j in
              (A $$ (i1,j1)) * (B $$ (i2,j2))))"

lemma tensor_op_jnf_dim[simp]:
  \<open>dim_row (tensor_op_jnf a b) = dim_row a * dim_row b\<close>
  \<open>dim_col (tensor_op_jnf a b) = dim_col a * dim_col b\<close>
  unfolding tensor_op_jnf_def Let_def by simp_all

lemma mat_of_cblinfun_tensor_op:
  fixes a :: \<open>'a::enum ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b::enum ell2\<close> and b :: \<open>'c::enum ell2 \<Rightarrow>\<^sub>C\<^sub>L 'd::enum ell2\<close>
  shows \<open>mat_of_cblinfun (tensor_op a b) = tensor_op_jnf (mat_of_cblinfun a) (mat_of_cblinfun b)\<close>
  apply (rule eq_matI, simp_all add: )
  apply (subst mat_of_cblinfun_tensor_op_index, simp_all)
  by (simp add: tensor_op_jnf_def case_prod_beta Let_def)

lemma mat_of_cblinfun_assoc_ell2'[simp]:
  \<open>mat_of_cblinfun (assoc_ell2' :: (('a::enum\<times>('b::enum\<times>'c::enum)) ell2 \<Rightarrow>\<^sub>C\<^sub>L _)) = one_mat (CARD('a)*CARD('b)*CARD('c))\<close>
  (is "mat_of_cblinfun ?assoc = _")
proof  (rule mat_eq_iff[THEN iffD2], intro conjI allI impI)

  show \<open>dim_row (mat_of_cblinfun ?assoc) =
    dim_row (1\<^sub>m (CARD('a) * CARD('b) * CARD('c)))\<close>
    by (simp)
  show \<open>dim_col (mat_of_cblinfun ?assoc) =
    dim_col (1\<^sub>m (CARD('a) * CARD('b) * CARD('c)))\<close>
    by (simp)

  fix i j
  let ?i = "Enum.enum ! i :: (('a\<times>'b)\<times>'c)" and ?j = "Enum.enum ! j :: ('a\<times>('b\<times>'c))"

  assume \<open>i < dim_row (1\<^sub>m (CARD('a) * CARD('b) * CARD('c)))\<close>
  then have iB[simp]: \<open>i < CARD('a) * CARD('b) * CARD('c)\<close> by simp
  then have iB'[simp]: \<open>i < CARD('a) * (CARD('b) * CARD('c))\<close> by linarith
  assume \<open>j < dim_col (1\<^sub>m (CARD('a) * CARD('b) * CARD('c)))\<close>
  then have jB[simp]: \<open>j < CARD('a) * CARD('b) * CARD('c)\<close> by simp
  then have jB'[simp]: \<open>j < CARD('a) * (CARD('b) * CARD('c))\<close> by linarith

  define i1 i23 i2 i3
    where "i1 = fst (tensor_unpack CARD('a) (CARD('b)*CARD('c)) i)"
      and "i23 = snd (tensor_unpack CARD('a) (CARD('b)*CARD('c)) i)"
      and "i2 = fst (tensor_unpack CARD('b) CARD('c) i23)"
      and "i3 = snd (tensor_unpack CARD('b) CARD('c) i23)"
  define j12 j1 j2 j3
    where "j12 = fst (tensor_unpack (CARD('a)*CARD('b)) CARD('c) j)"
      and "j1 = fst (tensor_unpack CARD('a) CARD('b) j12)"
      and "j2 = snd (tensor_unpack CARD('a) CARD('b) j12)"
      and "j3 = snd (tensor_unpack (CARD('a)*CARD('b)) CARD('c) j)"

  have [simp]: "j12 < CARD('a)*CARD('b)" "i23 < CARD('b)*CARD('c)"
    using j12_def jB tensor_unpack_bound1 apply presburger
    using i23_def iB' tensor_unpack_bound2 by blast

  have j1': \<open>fst (tensor_unpack CARD('a) (CARD('b) * CARD('c)) j) = j1\<close>
    by (simp add: j1_def j12_def tensor_unpack_fstfst)

  let ?i1 = "Enum.enum ! i1 :: 'a" and ?i2 = "Enum.enum ! i2 :: 'b" and ?i3 = "Enum.enum ! i3 :: 'c"
  let ?j1 = "Enum.enum ! j1 :: 'a" and ?j2 = "Enum.enum ! j2 :: 'b" and ?j3 = "Enum.enum ! j3 :: 'c"

  have i: \<open>?i = ((?i1,?i2),?i3)\<close>
    by (auto simp add: enum_prod_nth_tensor_unpack case_prod_beta
          tensor_unpack_fstfst tensor_unpack_fstsnd tensor_unpack_sndsnd i1_def i2_def i23_def i3_def)
  have j: \<open>?j = (?j1,(?j2,?j3))\<close>
    by (auto simp add: enum_prod_nth_tensor_unpack case_prod_beta
        tensor_unpack_fstfst tensor_unpack_fstsnd tensor_unpack_sndsnd j1_def j2_def j12_def j3_def)
  have ijeq: \<open>(?i1,?i2,?i3) = (?j1,?j2,?j3) \<longleftrightarrow> i = j\<close>
    unfolding i1_def i2_def i3_def j1_def j2_def j3_def apply simp
    apply (subst enum_inj, simp, simp)
    apply (subst enum_inj, simp, simp)
    apply (subst enum_inj, simp, simp)
    apply (subst tensor_unpack_inj[symmetric, where i=i and j=j and A="CARD('a)" and B="CARD('b)*CARD('c)"], simp, simp)
    unfolding prod_eq_iff
    apply (subst tensor_unpack_inj[symmetric, where i=\<open>snd (tensor_unpack CARD('a) (CARD('b) * CARD('c)) i)\<close> and A="CARD('b)" and B="CARD('c)"], simp, simp)
    by (simp add: i1_def[symmetric] j1_def[symmetric] i2_def[symmetric] j2_def[symmetric] i3_def[symmetric] j3_def[symmetric]
        i23_def[symmetric] j12_def[symmetric] j1'
        prod_eq_iff tensor_unpack_fstsnd tensor_unpack_sndsnd)

  have \<open>mat_of_cblinfun ?assoc $$ (i, j) = Rep_ell2 (assoc_ell2' *\<^sub>V ket ?j) ?i\<close>
    by (subst mat_of_cblinfun_ell2_component, auto)
  also have \<open>\<dots> = Rep_ell2 ((ket ?j1 \<otimes>\<^sub>s ket ?j2) \<otimes>\<^sub>s ket ?j3) ?i\<close>
    by (simp add: j assoc_ell2'_tensor flip: tensor_ell2_ket)
  also have \<open>\<dots> = (if (?i1,?i2,?i3) = (?j1,?j2,?j3) then 1 else 0)\<close>
    by (auto simp add: ket.rep_eq i)
  also have \<open>\<dots> = (if i=j then 1 else 0)\<close>
    using ijeq by simp
  finally
  show \<open>mat_of_cblinfun ?assoc $$ (i, j) =
           1\<^sub>m (CARD('a) * CARD('b) * CARD('c)) $$ (i, j)\<close>
    by auto
qed

lemma assoc_ell2'_inv: "assoc_ell2 o\<^sub>C\<^sub>L assoc_ell2' = id_cblinfun"
  apply (rule equal_ket, case_tac x, hypsubst)
  by (simp flip: tensor_ell2_ket add: cblinfun_apply_cblinfun_compose assoc_ell2'_tensor assoc_ell2_tensor)

lemma assoc_ell2_inv: "assoc_ell2' o\<^sub>C\<^sub>L assoc_ell2 = id_cblinfun"
  apply (rule equal_ket, case_tac x, hypsubst)
  by (simp flip: tensor_ell2_ket add: cblinfun_apply_cblinfun_compose assoc_ell2'_tensor assoc_ell2_tensor)

lemma mat_of_cblinfun_assoc_ell2[simp]:
  \<open>mat_of_cblinfun (assoc_ell2 :: ((('a::enum\<times>'b::enum)\<times>'c::enum) ell2 \<Rightarrow>\<^sub>C\<^sub>L _)) = one_mat (CARD('a)*CARD('b)*CARD('c))\<close>
  (is "mat_of_cblinfun ?assoc = _")
proof -
  let ?assoc' = "assoc_ell2' :: (('a::enum\<times>('b::enum\<times>'c::enum)) ell2 \<Rightarrow>\<^sub>C\<^sub>L _)"
  have "one_mat (CARD('a)*CARD('b)*CARD('c)) = mat_of_cblinfun (?assoc o\<^sub>C\<^sub>L ?assoc')"
    by (simp add: mult.assoc mat_of_cblinfun_id)
  also have \<open>\<dots> = mat_of_cblinfun ?assoc * mat_of_cblinfun ?assoc'\<close>
    using mat_of_cblinfun_compose by blast
  also have \<open>\<dots> = mat_of_cblinfun ?assoc * one_mat (CARD('a)*CARD('b)*CARD('c))\<close>
    by simp
  also have \<open>\<dots> = mat_of_cblinfun ?assoc\<close>
    apply (rule right_mult_one_mat')
    by (simp)
  finally show ?thesis
    by simp
qed

end


theory Poly
imports Main
begin

section {* Poly *}
subsection {* Polymorphism *}
subsubsection {* Polymorphic Lists *}

datatype 'a list = nil | cons 'a "'a list"

no_notation
  List.Nil ("[]")

notation
  nil ("[]") and
  cons (infixr ";" 60)

no_syntax
  "_list" :: "args \<Rightarrow> 'a list" ("[(_)]")

syntax
  "_polylist" :: "args \<Rightarrow> 'a list" ("[(_)]")

translations
  "[x; xs]" == "x;[xs]"
  "[x]" == "x;[]"

term "nil"
  (* \<Longrightarrow> "nil" :: "'a Poly.list" *)
term "cons"
  (* \<Longrightarrow> "cons" :: "'a \<Rightarrow> 'a Poly.list \<Rightarrow> 'a Poly.list" *)

value "cons 2 (cons (1 :: nat) nil)"
  (* \<Longrightarrow> "cons (Suc (Suc 0)) (cons (Suc 0) nil)" :: "nat Poly.list" *)

fun length :: "'a list \<Rightarrow> nat" where
  "length nil = 0"
  | "length (cons h t) = Suc (length t)"

lemma test_length1: "length (cons 1 (cons 2 nil)) = 2" by simp
lemma test_length2: "length (cons True nil) = 1" by simp

fun app :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "app nil l2 = l2"
  | "app (cons h t) l2 = cons h (app t l2)"

fun snoc :: "'a list \<Rightarrow> 'a \<Rightarrow> 'a list" where
  "snoc nil v = cons v nil"
  | "snoc (cons h t) v = cons h (snoc t v)"

fun rev :: "'a list \<Rightarrow> 'a list" where
  "rev nil = nil"
  | "rev (cons h t) = snoc (rev t) h"

lemma test_rev1: "rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil))" by simp
lemma test_rev2: "rev nil = nil" by simp

(* Exercise: 2 stars (mumble_grumble) *)

datatype mumble = a' | b' mumble nat | c'
datatype 'a grumble = d' mumble | e' 'a

term "d' (b' a' 5)"
  (* \<Longrightarrow> "d' (b' a' 5)" :: "'a grumble" *)
term "d' (b' a' 5) :: mumble grumble"
  (* \<Longrightarrow> "d' (b' a' 5)" :: "mumble grumble" *)
term "d' (b' a' 5) :: bool grumble"
  (* \<Longrightarrow> "d' (b' a' 5)" :: "bool grumble" *)
term "e' True"
  (* \<Longrightarrow> "e' True" :: "bool grumble" *)
term "e' (b' c' 0) :: mumble grumble"
  (* \<Longrightarrow> "e' (b' c' 0)" :: "mumble grumble" *)
(* term "e' (b' c' 0) :: bool grumble" \<Longrightarrow> error *)
term "c'"
  (* \<Longrightarrow> "c'" :: "mumble" *)

(* Exercise: 2 stars (baz_num_elts) *)

(*
datatype baz = x baz | y baz bool

baz has no element
*)

subsubsection {* Type Annotation Inference *}
subsubsection {* Type Argument Synthesis *}
subsubsection {* Implicit Arguments *}
subsubsection {* Exercises: Polymorphic Lists *}

(* Exercise: 2 stars, optional (poly_exercises) *)

fun repeat :: "'a \<Rightarrow> nat \<Rightarrow> 'a list" where
  "repeat x 0 = nil"
  | "repeat x (Suc n) = cons x (repeat x n)"

lemma test_repeat1: "repeat True 2 = cons True (cons True nil)"
proof -
  have 2: "2 = Suc 1" by simp
  show ?thesis by (simp add: 2)
qed

theorem nil_app: "\<forall>l::'a list. app nil l = l" by simp
theorem rev_snoc: "\<forall>v :: 'a. \<forall>s :: 'a list. rev (snoc s v) = cons v (rev s)"
apply auto by (induct_tac s, auto)

theorem rev_involutive: "\<forall>l :: 'a list. rev (rev l) = l"
apply auto by (induct_tac l,  auto simp add: rev_snoc)

theorem snoc_with_append: "\<forall>l1 l2 :: 'a list. \<forall>v :: 'a. snoc (app l1 l2) v = app l1 (snoc l2 v)"
apply auto by (induct_tac l1, auto)

subsubsection {* Polymorphic Pairs *}

datatype ('a,'b) prod = pair 'a 'b

no_type_notation
  Product_Type.prod  ("(_ \<times>/ _)" [21, 20] 20)

type_notation
  prod  ("_ \<times> _")

primrec fst :: "('a \<times> 'b) \<Rightarrow> 'a" where
  "fst (pair x _) = x"
primrec snd :: "('a \<times> 'b) \<Rightarrow> 'b" where
  "snd (pair _ y) = y"

fun combine :: "'a list \<Rightarrow> 'b list \<Rightarrow> ('a \<times> 'b) list" where
  "combine nil _ = nil"
  | "combine _ nil = nil"
  | "combine (cons x xs) (cons y ys) = cons (pair x y) (combine xs ys)"

(* Exercise: 1 star, optional (combine_checks) *)

value "combine [1;2] [false;false;true;true]"
  (* \<Longrightarrow> "[pair 1 false ; pair (1 + 1) false]" :: "'a \<times> 'b Poly.list" *)

(* Exercise: 2 stars (split) *)

fun pair_map :: "(('a \<Rightarrow> 'c) \<times> ('b \<Rightarrow> 'd)) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> ('c \<times> 'd)" where
  "pair_map (pair f g) (pair x y) = pair (f x) (g y)"

fun split :: "('a \<times> 'b) list \<Rightarrow> (('a list) \<times> ('b list))" where
  "split nil = pair nil nil"
  | "split (pair x y ; zs) = pair_map (pair (cons x) (cons y)) (split zs)"

lemma test_split: "split [pair 1 false; pair 2 false] = pair [1;2] [false;false]" by simp

subsubsection {* Polymorphic Options *}

datatype 'a option = Some 'a | None

fun index :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a option" where
  "index _ nil = None"
  | "index n (cons a l) = (if n = 0 then Some a else index (n - 1) l)"

lemma test_index1: "index 0 [4;5;6;7] = Some 4" by simp
lemma test_index2: "index 1 [[1];[2]] = Some [2]" by simp
lemma test_index3: "index 2 [True] = None" by simp

(* Exercise: 1 star, optional (hd_opt_poly) *)

fun hd_opt :: "'a list \<Rightarrow> 'a option" where
  "hd_opt nil = None"
  | "hd_opt (h ; t) = Some h"

term "hd_opt"
  (* \<Longrightarrow> "hd_opt" :: "'a Poly.list \<Rightarrow> 'a Poly.option" *)

lemma test_hd_opt1: "hd_opt [1;2] = Some 1" by simp
lemma test_hd_opt2: "hd_opt [[1];[2]] = Some [1]" by simp

subsection {* Functions as Data *}
subsubsection {* Higher-Order Functions *}

fun doit3times :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" where
  "doit3times f x = f (f (f x))"

term "doit3times"
  (* \<Longrightarrow> "doit3times" :: "('a \<Rightarrow> 'a) \<Rightarrow> 'a \<Rightarrow> 'a" *)

lemma test_doit3times: "doit3times (\<lambda>(x :: nat). x - 2) 9 = 3" by simp
lemma test_doit3times': "doit3times (\<lambda>x. \<not> x) True = False" by simp

subsubsection {* Partial Application *}

definition "plus3 = plus (3 :: nat)"
term "plus3"
  (* \<Longrightarrow> "plus3" :: "nat \<Rightarrow> nat" *)

lemma test_plus3: "plus3 4 = 7" unfolding plus3_def by simp
lemma test_plus3': "doit3times plus3 0 = 9" unfolding plus3_def by simp
lemma test_plus3'' : "doit3times (plus (3 :: nat)) 0 = 9" by simp

subsubsection {* Digression: Currying *}

(* Exercise: 2 stars, advanced (currying) *)

fun prod_curry :: "(('a \<times> 'b) \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'c" where
  "prod_curry f x y = f (pair x y)"
fun prod_uncurry :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a \<times> 'b) \<Rightarrow> 'c" where
  "prod_uncurry f (pair x y) = f x y"

term prod_curry
  (* "prod_curry" :: "('a \<times> 'b \<Rightarrow> 'c) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'c" *)
term prod_uncurry
  (* "prod_uncurry" :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> 'a \<times> 'b \<Rightarrow> 'c" *)

theorem uncurry_curry: "\<forall>(f :: 'a \<Rightarrow> 'b \<Rightarrow> 'c) x y. prod_curry (prod_uncurry f) x y = f x y" by simp
theorem curry_uncurry: "\<forall>(f :: ('a \<times> 'b) \<Rightarrow> 'c) (p :: 'a \<times> 'b). prod_uncurry (prod_curry f) p = f p"
apply auto by (case_tac p, auto)

subsubsection {* Filter *}

fun filter :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "filter test nil = nil"
  | "filter test (h;t) = (if test h then h ; (filter test t) else filter test t)"

lemma test_filter1: "filter (\<lambda>(x :: nat). x mod 2 = 0) [1;2;3;4] = [2;4]" by simp

fun length_is_1 :: "'a list \<Rightarrow> bool" where
  "length_is_1 l = (length l = 1)"

lemma test_filter2: "filter length_is_1 [[1;2];[3];[4];[5;6;7];[];[8]] = [[3];[4];[8]]" by simp

fun countoddmembers' :: "nat list \<Rightarrow> nat" where
  "countoddmembers' l = length (filter (\<lambda>x. x mod 2 = 1) l)"

lemma test_countoddmembers'1: "countoddmembers' [1;0;3;1;4;5] = 4" by simp
lemma test_countoddmembers'2: "countoddmembers' [0;2;4] = 0" by simp
lemma test_countoddmembers'3: "countoddmembers' nil = 0" by simp

subsubsection {* Anonymous Functions *}

lemma test_anon_fun': "doit3times (\<lambda>(n :: nat). n * n) 2 = 256" by simp
lemma test_filter2': "filter (\<lambda>l. length l = 1) [[1; 2];[3];[4];[5;6;7];[];[8]] = [[3];[4];[8]]" by simp

(* Exercise: 2 stars (filter_even_gt7) *)

fun filter_even_gt7 :: "nat list \<Rightarrow> nat list" where
  "filter_even_gt7 l = filter (\<lambda>x. x mod 2 = 0 & x \<ge> 7) l"

lemma test_filter_even_gt7_1: "filter_even_gt7 [1;2;6;9;10;3;12;8] = [10;12;8]" by simp
lemma test_filter_even_gt7_2: "filter_even_gt7 [5;2;6;19;129] = []" by simp

(* Exercise: 3 stars (partition) *)
fun partition :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> (('a list) \<times> ('a list))" where
  "partition f xs = pair (filter f xs) (filter (\<lambda>x. \<not> f x) xs)"

lemma test_partition1: "partition (\<lambda>(x :: nat). x mod 2 = 1) [1;2;3;4;5] = pair [1;3;5] [2;4]" by simp
lemma test_partition2: "partition (\<lambda>_. False) [5;9;0] = pair [] [5;9;0]" by simp

subsubsection {* Map *}

fun map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
  "map f nil = nil"
  | "map f (h;t) = f h ; map f t"

lemma test_map1: "map (\<lambda>(x :: nat). x + 3) [2;0;2] = [5;3;5]" by simp
lemma test_map2: "map (\<lambda>(x :: nat). x mod 2 = 1) [2;1;2;5] = [False;True;False;True]" by simp
lemma test_map3: "map (\<lambda>(n :: nat). [(n mod 2 = 0) ; (n mod 2 = 1)]) [2;1;2;5] = [[True;False];[False;True];[True;False];[False;True]]"
by simp

subsubsection {* Map for options *}

(* Exercise: 3 stars (map_rev) *)

lemma map_rev_lem: "\<And>f l a. map f (snoc l a) = snoc (map f l) (f a)"
by (induct_tac l, auto)

theorem map_rev: "\<forall>(f :: 'a \<Rightarrow> 'b) (l :: 'a list). map f (rev l) = rev (map f l)"
apply auto by (induct_tac l, auto simp add: map_rev_lem)

(* Exercise: 2 stars (flat_map) *)

fun flat_map :: "('a \<Rightarrow> 'b list) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
  "flat_map f nil = nil"
  | "flat_map f (h;t) = app (f h) (flat_map f t)"

lemma test_flat_map1: "flat_map (\<lambda>n. [n;n;n]) [1;5;4] = [1; 1; 1; 5; 5; 5; 4; 4; 4]" by simp

fun option_map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a option \<Rightarrow> 'b option" where
  "option_map f None = None"
  | "option_map f (Some a) = Some (f a)"

(* Exercise: 2 stars, optional (implicit_args) *)

subsubsection {* Fold *}

fun fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b \<Rightarrow> 'b" where
  "fold f nil b = b"
  | "fold f (h;t) b = f h (fold f t b)"

term "fold (\<lambda>x y. x \<and> y)"
  (* \<Longrightarrow> "Poly.fold op \<and>" :: "bool Poly.list \<Rightarrow> bool \<Rightarrow> bool" *)

lemma fold_example1: "fold (\<lambda>(x :: nat) y. x * y) [1;2;3;4] 1 = 24" by simp
lemma fold_example2: "fold (\<lambda>x y. x \<and> y) [True;True;False;True] True = False" by simp
lemma fold_example3: "fold app [[1];[];[2;3];[4]] [] = [1;2;3;4]" by simp

(* Exercise: 1 star, advanced (fold_types_different) *)

subsubsection {* Functions For Constructing Functions *}

fun constfun :: "'a \<Rightarrow> nat \<Rightarrow> 'a" where
  "constfun x = (\<lambda>_. x)"
fun ftrue where
  "ftrue x = constfun True x"

lemma constfun_example1: "ftrue 0 = True" by simp
lemma constfun_example2: "(constfun 5) 99 = 5" by simp

fun override :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a" where
  "override f k x = (\<lambda>(k' :: nat). if k = k' then x else f k')"
fun fmostlytrue where
  "fmostlytrue x = override (override ftrue 1 False) 3 False x"

lemma override_example1: "fmostlytrue 0 = True" by simp
lemma override_example2: "fmostlytrue 1 = False" by simp
lemma override_example3: "fmostlytrue 2 = True" by simp
lemma override_example4: "fmostlytrue 3 = False" by simp

(* Exercise: 1 star (override_example) *)

theorem override_example: "\<forall>(b::bool). (override (constfun b) 3 True) 2 = b" by simp

subsection {* The unfold Tactic *}

theorem unfold_example: "\<forall>(m :: nat) n. 3 + n = m \<longrightarrow> plus3 n + 1 = m + 1"
unfolding plus3_def by simp

theorem override_eq: "\<forall>x k (f :: nat \<Rightarrow> 'a). (override f k x) k = x" by simp
theorem override_neq: "\<forall>x1 x2 k1 k2 (f :: nat \<Rightarrow> 'a). f k1 = x1 \<longrightarrow> k2 \<noteq> k1 \<longrightarrow> (override f k2 x2) k1 = x1" by simp

(* Additional Exercises *)

fun fold_length :: "'a list \<Rightarrow> nat" where
  "fold_length l = fold (\<lambda>_ n. Suc n) l 0"

lemma test_fold_length1: "fold_length [4;7;0] = 3" by simp

theorem fold_length_correct: "\<forall>(l :: 'a list). fold_length l = length l"
apply auto by (induct_tac l, auto)

(* Exercise: 3 stars (fold_map) *)

fun fold_map :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
  "fold_map f xs = fold (\<lambda>a b. f a ; b) xs nil"

lemma fold_map_correct: "\<forall>f l. fold_map f l = map f l"
apply auto by (induct_tac l, auto)

end


theory Ex030
  imports Main
begin

lemma "(A \<longrightarrow> B \<longrightarrow> C)  \<longleftrightarrow> (\<not>C \<longrightarrow> A \<longrightarrow> \<not>B)"
proof -
  {
    assume a:"A \<longrightarrow> B \<longrightarrow> C"
    {
      assume b:"\<not>C"
      {
        assume A
        with a have c:"B \<longrightarrow> C" by (rule mp)
        {
          assume B
          with c have C by (rule mp)
          with b have False by contradiction
        }
        hence "\<not>B" by (rule notI)
      }
      hence "A \<longrightarrow> \<not>B" by (rule impI)
    }
    hence "\<not>C \<longrightarrow> A \<longrightarrow> \<not>B" by (rule impI)
  }
  moreover
  {
    assume d:"\<not>C \<longrightarrow> A \<longrightarrow> \<not>B"
    {
      assume e:A
      {
        assume f:B
        {
          assume "\<not>C"
          with d have "A \<longrightarrow> \<not>B" by (rule mp)
          from this and e have "\<not>B" by (rule mp)
          with f have False by contradiction
        }
        hence "\<not>\<not>C" by (rule notI)
        hence C by (rule notnotD)
      }
      hence "B \<longrightarrow> C" by (rule impI)
    }
    hence "A \<longrightarrow> B \<longrightarrow> C" by (rule impI)
  }
  ultimately show ?thesis by (rule iffI)
qed


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.
   Some proofs were added by Yutaka Nagashima.*)
theory TIP_prop_63
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun len :: "'a list => Nat" where
  "len (nil2) = Z"
| "len (cons2 y xs) = S (len xs)"

fun last :: "Nat list => Nat" where
  "last (nil2) = Z"
| "last (cons2 y (nil2)) = y"
| "last (cons2 y (cons2 x2 x3)) = last (cons2 x2 x3)"

fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
| "drop (S z) (nil2) = nil2"
| "drop (S z) (cons2 x2 x3) = drop z x3"

fun t2 :: "Nat => Nat => bool" where
  "t2 x (Z) = False"
| "t2 (Z) (S z) = True"
| "t2 (S x2) (S z) = t2 x2 z"

theorem property0 :
  "((t2 n (len xs)) ==> ((last (drop n xs)) = (last xs)))"
  oops

end


(*
  File: Field.thy
  Author: Bohua Zhan

  Fields and the archimedean condition.
*)

theory Field
  imports Ring
begin

section \<open>Fields\<close>

definition is_field :: "i \<Rightarrow> o" where [rewrite]:
  "is_field(R) \<longleftrightarrow> (is_comm_ring(R) \<and> (\<forall>x\<in>.R. x \<noteq> \<zero>\<^sub>R \<longleftrightarrow> x \<in> units(R)))"

lemma is_fieldD [forward]:
  "is_field(R) \<Longrightarrow> is_comm_ring(R)"
  "is_field(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> x \<noteq> \<zero>\<^sub>R \<Longrightarrow> x \<in> units(R)"
  "is_field(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> x \<notin> units(R) \<Longrightarrow> x = 0\<^sub>R" by auto2+

lemma is_fieldD2 [resolve]:
  "is_field(R) \<Longrightarrow> \<zero>\<^sub>R \<notin> units(R)" by auto2

lemma is_fieldI [backward1]:
  "is_comm_ring(R) \<Longrightarrow> \<forall>x\<in>.R. x \<noteq> \<zero>\<^sub>R \<longrightarrow> f(x) \<in>. R \<Longrightarrow>
   \<forall>x\<in>.R. x \<noteq> \<zero>\<^sub>R \<longrightarrow> x *\<^sub>R f(x) = \<one>\<^sub>R \<Longrightarrow> is_field(R)" by auto2

lemma is_field_ring_prop [forward]:
  "is_ring_raw(H) \<Longrightarrow> is_field(G) \<Longrightarrow> eq_str_ring(G,H) \<Longrightarrow> is_field(H)" by auto2
setup {* del_prfstep_thm @{thm is_field_def} *}

lemma field_is_integral_domain [forward]:
  "is_field(R) \<Longrightarrow> integral_domain(R)"
@proof
  @have "\<forall>x\<in>.R. \<forall>y\<in>.R. x *\<^sub>R y = \<zero>\<^sub>R \<longrightarrow> x = \<zero>\<^sub>R \<or> y = \<zero>\<^sub>R" @with
    @contradiction @have "x *\<^sub>R y \<in> units(R)" @end
@qed

section \<open>Ordered fields\<close>

definition is_ord_field :: "i \<Rightarrow> o" where [rewrite]:
  "is_ord_field(R) \<longleftrightarrow> (is_ord_ring(R) \<and> is_field(R))"

lemma is_ord_fieldD [forward]:
  "is_ord_field(R) \<Longrightarrow> is_ord_ring(R)"
  "is_ord_field(R) \<Longrightarrow> is_field(R)" by auto2+

lemma is_ord_fieldI [forward]:
  "is_ord_ring(R) \<Longrightarrow> is_field(R) \<Longrightarrow> is_ord_field(R)" by auto2
setup {* del_prfstep_thm @{thm is_ord_field_def} *}

lemma is_ord_field_prop [forward]:
  "is_ord_field(R) \<Longrightarrow> is_ord_ring_raw(S) \<Longrightarrow> eq_str_ord_ring(R,S) \<Longrightarrow> is_ord_field(S)" by auto2

lemma ord_field_inv_sign [backward]:
  "is_ord_field(R) \<Longrightarrow> x >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> inv(R,x) >\<^sub>R \<zero>\<^sub>R"
@proof @have "x *\<^sub>R inv(R,x) = \<one>\<^sub>R" @have "\<one>\<^sub>R >\<^sub>R \<zero>\<^sub>R" @qed
setup {* add_forward_prfstep_cond @{thm ord_field_inv_sign} [with_term "inv(?R,?x)"] *}

lemma ord_field_inv_sign2 [backward]:
  "is_ord_field(R) \<Longrightarrow> x <\<^sub>R \<zero>\<^sub>R \<Longrightarrow> inv(R,x) <\<^sub>R \<zero>\<^sub>R"
@proof @have "inv(R,-\<^sub>R x) = -\<^sub>R inv(R,x)" @qed
setup {* add_forward_prfstep_cond @{thm ord_field_inv_sign2} [with_term "inv(?R,?x)"] *}

lemma ord_field_inv_le [backward2]:
  "is_ord_field(R) \<Longrightarrow> \<zero>\<^sub>R <\<^sub>R a \<Longrightarrow> a \<le>\<^sub>R b \<Longrightarrow> inv(R,a) \<ge>\<^sub>R inv(R,b)"
@proof @case "inv(R,a) <\<^sub>R inv(R,b)" @with @have "inv(R,a) *\<^sub>R a <\<^sub>R inv(R,b) *\<^sub>R b" @end @qed

lemma ord_field_inv_lt [backward2]:
  "is_ord_field(R) \<Longrightarrow> \<zero>\<^sub>R <\<^sub>R a \<Longrightarrow> a <\<^sub>R b \<Longrightarrow> inv(R,a) >\<^sub>R inv(R,b)"
@proof @case "inv(R,a) \<le>\<^sub>R inv(R,b)" @with @have "inv(R,a) *\<^sub>R a <\<^sub>R inv(R,b) *\<^sub>R b" @end @qed

lemma ord_field_inv_le' [backward1]:
  "is_ord_field(R) \<Longrightarrow> x >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> y >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> x >\<^sub>R inv(R,y) \<Longrightarrow> y >\<^sub>R inv(R,x)"
@proof @have "x = inv(R,inv(R,x))" @qed

lemma ord_field_div_sign [backward1, backward2]:
  "is_ord_field(R) \<Longrightarrow> x >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> y >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> x /\<^sub>R y >\<^sub>R \<zero>\<^sub>R"
@proof @have "x /\<^sub>R y = x *\<^sub>R inv(R,y)" @qed
setup {* add_forward_prfstep_cond @{thm ord_field_div_sign} [with_term "?x /\<^sub>?R ?y"] *}

lemma ord_field_div_sign2 [forward]:
  "is_ord_field(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in> units(R) \<Longrightarrow> x /\<^sub>R y >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> y >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> x >\<^sub>R \<zero>\<^sub>R"
@proof @have "x /\<^sub>R y = x *\<^sub>R inv(R,y)" @qed

lemma ord_field_divide_le [backward]:
  "is_ord_field(R) \<Longrightarrow> c >\<^sub>R 0\<^sub>R \<Longrightarrow> a \<le>\<^sub>R b \<Longrightarrow> a /\<^sub>R c \<le>\<^sub>R b /\<^sub>R c"
@proof @have "a /\<^sub>R c = a *\<^sub>R inv(R,c)" @have "b /\<^sub>R c = b *\<^sub>R inv(R,c)" @qed

lemma ord_field_divide_less [backward]:
  "is_ord_field(R) \<Longrightarrow> c >\<^sub>R 0\<^sub>R \<Longrightarrow> a <\<^sub>R b \<Longrightarrow> a /\<^sub>R c <\<^sub>R b /\<^sub>R c"
@proof @have "a *\<^sub>R inv(R,c) <\<^sub>R b *\<^sub>R inv(R,c)" @qed

lemma ord_field_divide_less2 [backward1]:
  "is_ord_field(R) \<Longrightarrow> c \<in>. R \<Longrightarrow> a >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> b >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> inv(R,a) <\<^sub>R c /\<^sub>R b \<Longrightarrow> b <\<^sub>R a *\<^sub>R c"
@proof @have "inv(R,a) *\<^sub>R (a *\<^sub>R b) <\<^sub>R (c /\<^sub>R b) *\<^sub>R (a *\<^sub>R b)" @qed

lemma ord_field_divide_le2 [backward1]:
  "is_ord_field(R) \<Longrightarrow> b \<in>. R \<Longrightarrow> c >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> a \<le>\<^sub>R b /\<^sub>R c \<Longrightarrow> a *\<^sub>R c \<le>\<^sub>R b"
@proof @have "a *\<^sub>R c \<le>\<^sub>R b /\<^sub>R c *\<^sub>R c" @qed

lemma ord_field_divide_le2' [backward1]:
  "is_ord_field(R) \<Longrightarrow> b \<in>. R \<Longrightarrow> c >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> a \<le>\<^sub>R b /\<^sub>R c \<Longrightarrow> c *\<^sub>R a \<le>\<^sub>R b"
@proof @have "a *\<^sub>R c \<le>\<^sub>R b /\<^sub>R c *\<^sub>R c" @qed

lemma ord_field_divide_le3 [backward1]:
  "is_ord_field(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> c >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> a *\<^sub>R c \<le>\<^sub>R b \<Longrightarrow> a \<le>\<^sub>R b /\<^sub>R c"
@proof @have "a *\<^sub>R c \<le>\<^sub>R b /\<^sub>R c *\<^sub>R c" @qed

lemma ord_field_divide_le4 [backward1]:
  "is_ord_field(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> c >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> c *\<^sub>R a \<le>\<^sub>R b \<Longrightarrow> a \<le>\<^sub>R b /\<^sub>R c"
@proof @have "a *\<^sub>R c = c *\<^sub>R a" @qed

lemma ord_field_divide_le5 [backward1]:
  "is_ord_field(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> c >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> c *\<^sub>R a \<ge>\<^sub>R b \<Longrightarrow> a \<ge>\<^sub>R b /\<^sub>R c"
@proof @have "a *\<^sub>R c \<ge>\<^sub>R b /\<^sub>R c *\<^sub>R c" @qed

lemma ord_field_divide_less4 [backward1]:
  "is_ord_field(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> c >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> c *\<^sub>R a <\<^sub>R b \<Longrightarrow> a <\<^sub>R b /\<^sub>R c"
@proof @have "a *\<^sub>R c <\<^sub>R b /\<^sub>R c *\<^sub>R c" @qed

lemma ord_field_divide_less4' [backward1]:
  "is_ord_field(R) \<Longrightarrow> b \<in>. R \<Longrightarrow> c >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> a \<ge>\<^sub>R b /\<^sub>R c \<Longrightarrow> c *\<^sub>R a \<ge>\<^sub>R b"
@proof @have "a *\<^sub>R c \<ge>\<^sub>R b /\<^sub>R c *\<^sub>R c" @qed

lemma ord_field_divide_less5 [backward1]:
  "is_ord_field(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> c >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> c *\<^sub>R a >\<^sub>R b \<Longrightarrow> a >\<^sub>R b /\<^sub>R c"
@proof @have "a *\<^sub>R c >\<^sub>R b /\<^sub>R c *\<^sub>R c" @qed

lemma ord_field_divide_less6 [backward1]:
  "is_ord_field(R) \<Longrightarrow> c \<in>. R \<Longrightarrow> d \<in>. R \<Longrightarrow> b >\<^sub>R 0\<^sub>R \<Longrightarrow> d <\<^sub>R c /\<^sub>R b \<Longrightarrow> c >\<^sub>R d *\<^sub>R b"
@proof @have "d *\<^sub>R b <\<^sub>R c /\<^sub>R b *\<^sub>R b" @qed

lemma ord_field_quotient_less [backward]:
  "is_ord_field(R) \<Longrightarrow> a \<ge>\<^sub>R 0\<^sub>R \<Longrightarrow> b \<ge>\<^sub>R 1\<^sub>R \<Longrightarrow> a /\<^sub>R b \<le>\<^sub>R a"
@proof @have "(a /\<^sub>R b) *\<^sub>R b = a *\<^sub>R 1\<^sub>R" @case "(a /\<^sub>R b) *\<^sub>R b >\<^sub>R a *\<^sub>R b" @qed

section \<open>Fields of characteristic zero\<close>

lemma ord_field_char_zero [backward]:
  "is_ord_field(R) \<Longrightarrow> n \<in> nat \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> of_nat(R,n) \<in> units(R)"
@proof @have "of_nat(R,n) >\<^sub>R \<zero>\<^sub>R" @qed

lemma ord_field_exists_half [backward]:
  "is_ord_field(R) \<Longrightarrow> r >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> \<exists>s. s >\<^sub>R \<zero>\<^sub>R \<and> r = s +\<^sub>R s"
@proof @have "r = r /\<^sub>R 2\<^sub>R +\<^sub>R r /\<^sub>R 2\<^sub>R" @qed

lemma ord_field_exists_sum2 [backward]:
  "is_ord_field(R) \<Longrightarrow> r >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> \<exists>s t. s >\<^sub>R \<zero>\<^sub>R \<and> t >\<^sub>R \<zero>\<^sub>R \<and> r = s +\<^sub>R t"
@proof @have "r = r /\<^sub>R 2\<^sub>R +\<^sub>R r /\<^sub>R 2\<^sub>R" @qed

section \<open>Archimedean Fields\<close>

definition is_archimedean :: "i \<Rightarrow> o" where [rewrite]:
  "is_archimedean(R) \<longleftrightarrow> (is_ord_ring(R) \<and> (\<forall>x\<in>.R. \<exists>n\<in>nat. of_nat(R,n) \<ge>\<^sub>R x))"

lemma is_archimedeanI [forward]:
  "is_ord_ring(R) \<Longrightarrow> \<forall>x\<in>.R. \<exists>n\<in>nat. of_nat(R,n) \<ge>\<^sub>R x \<Longrightarrow> is_archimedean(R)" by auto2

lemma is_archimedeanI_pos [forward]:
  "is_ord_ring(R) \<Longrightarrow> \<forall>x >\<^sub>R 0\<^sub>R. \<exists>n\<in>nat. of_nat(R,n) \<ge>\<^sub>R x \<Longrightarrow> is_archimedean(R)" by auto2

lemma is_archimedeanD1 [forward]: "is_archimedean(R) \<Longrightarrow> is_ord_ring(R)" by auto2

lemma is_archimedeanD2 [backward]:
  "is_archimedean(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> \<exists>n\<in>nat. of_nat(R,n) \<ge>\<^sub>R x" by auto2
setup {* del_prfstep_thm @{thm is_archimedean_def} *}

lemma is_archimedeanD_greater [backward]:
  "is_archimedean(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> \<exists>n\<in>nat. of_nat(R,n) >\<^sub>R x"
@proof
  @obtain "n\<in>nat" where "of_nat(R,n) \<ge>\<^sub>R x"
  @have "of_nat(R, n +\<^sub>\<nat> 1) >\<^sub>R x"
@qed

lemma is_archimedeanD_nat_inverse_less [backward]:
  "is_archimedean(R) \<Longrightarrow> is_field(R) \<Longrightarrow> x >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> \<exists>n>\<^sub>\<nat>0. inv(R,of_nat(R,n)) <\<^sub>R x"
@proof
  @obtain "n\<in>nat" where "of_nat(R,n) >\<^sub>R inv(R,x)"
  @obtain n' where "n'>\<^sub>\<nat>0" "n' = max(\<nat>,n,1)"
  @have "of_nat(R,n') >\<^sub>R inv(R,x)"
@qed

lemma is_archimedeanD_nat_inverse_less_plus1 [backward]:
  "is_archimedean(R) \<Longrightarrow> is_field(R) \<Longrightarrow> x >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> \<exists>n\<in>nat. inv(R,of_nat(R,n +\<^sub>\<nat> 1)) <\<^sub>R x"
@proof
  @obtain n where "n>\<^sub>\<nat>0" "inv(R,of_nat(R,n)) <\<^sub>R x" @have "n \<ge>\<^sub>\<nat> 1"
  @have "n -\<^sub>\<nat> 1 \<in> nat"
@qed

lemma is_archimedeanD_quotient [backward2]:
  "is_archimedean(R) \<Longrightarrow> is_ord_field(R) \<Longrightarrow> b \<in>. R \<Longrightarrow> a >\<^sub>R \<zero>\<^sub>R \<Longrightarrow> \<exists>n\<in>.\<nat>. of_nat(R,n) *\<^sub>R a >\<^sub>R b"
@proof
  @case "b \<le>\<^sub>R \<zero>\<^sub>R" @with @have "of_nat(R,1) *\<^sub>R a >\<^sub>R b" @end
  @obtain n where "n>\<^sub>\<nat>0" "inv(R,of_nat(R,n)) <\<^sub>R a /\<^sub>R b"
@qed

lemma power_two_unbounded [backward]:
  "is_archimedean(R) \<Longrightarrow> M \<in>. R \<Longrightarrow> \<exists>n\<in>nat. 2\<^sub>R ^\<^sub>R n >\<^sub>R M"
@proof
  @obtain "n\<in>nat" where "of_nat(R,n) >\<^sub>R M" @have "2\<^sub>R ^\<^sub>R n >\<^sub>R of_nat(R,n)"
@qed

section \<open>Averages\<close>

definition avg :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "avg(R,a,b) = (a +\<^sub>R b) /\<^sub>R 2\<^sub>R"
setup {* register_wellform_data ("avg(R,a,b)", ["a \<in>. R", "b \<in>. R"]) *}

lemma avg_type [typing]: "is_ord_field(R) \<Longrightarrow> a \<in>. R \<Longrightarrow> b \<in>. R \<Longrightarrow> avg(R,a,b) \<in>. R" by auto2

lemma avg_le [backward]: "is_ord_field(R) \<Longrightarrow> a \<le>\<^sub>R b \<Longrightarrow> a \<le>\<^sub>R avg(R,a,b)"
@proof @have "a +\<^sub>R a \<le>\<^sub>R a +\<^sub>R b" @have "a +\<^sub>R a = 2\<^sub>R *\<^sub>R a" @qed

lemma avg_le2 [backward]: "is_ord_field(R) \<Longrightarrow> a \<le>\<^sub>R b \<Longrightarrow> avg(R,a,b) \<le>\<^sub>R b"
@proof @have "a +\<^sub>R b \<le>\<^sub>R b +\<^sub>R b" @have "b +\<^sub>R b = 2\<^sub>R *\<^sub>R b" @qed

lemma avg_less [backward]: "is_ord_field(R) \<Longrightarrow> a <\<^sub>R b \<Longrightarrow> a <\<^sub>R avg(R,a,b)"
@proof @have "a +\<^sub>R a <\<^sub>R a +\<^sub>R b" @have "a +\<^sub>R a = 2\<^sub>R *\<^sub>R a" @qed

lemma avg_less2 [backward]: "is_ord_field(R) \<Longrightarrow> a <\<^sub>R b \<Longrightarrow> avg(R,a,b) <\<^sub>R b"
@proof @have "a +\<^sub>R b <\<^sub>R b +\<^sub>R b" @have "b +\<^sub>R b = 2\<^sub>R *\<^sub>R b" @qed

lemma avg_ge [backward]: "is_ord_field(R) \<Longrightarrow> a \<ge>\<^sub>R b \<Longrightarrow> a \<ge>\<^sub>R avg(R,a,b)"
@proof @have "avg(R,a,b) = avg(R,b,a)" @qed

lemma avg_ge2 [backward]: "is_ord_field(R) \<Longrightarrow> a \<ge>\<^sub>R b \<Longrightarrow> avg(R,a,b) \<ge>\<^sub>R b"
@proof @have "avg(R,a,b) = avg(R,b,a)" @qed

lemma ord_field_dense [forward]: "is_ord_field(R) \<Longrightarrow> dense_order(R)"
@proof
  @have "\<forall>a b. a <\<^sub>R b \<longrightarrow> (\<exists>c. a <\<^sub>R c \<and> c <\<^sub>R b)" @with @have "a <\<^sub>R avg(R,a,b)" @end
@qed
setup {* del_prfstep_thm @{thm avg_def} *}

section \<open>Comparison of rational numbers\<close>

lemma ord_ring_of_nat_ge_zero' [backward]:
  "is_ord_ring(R) \<Longrightarrow> n \<in> nat \<Longrightarrow> of_nat(R,n) \<ge>\<^sub>R 0\<^sub>R" by auto2

lemma ord_ring_of_nat_greater_zero' [backward]:
  "is_ord_ring(R) \<Longrightarrow> n \<in> nat \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> of_nat(R,n) >\<^sub>R 0\<^sub>R" by auto2

lemma ord_field_rat_ge_zero:
  "is_ord_field(R) \<Longrightarrow> m \<in> nat \<Longrightarrow> n \<in> nat \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> of_nat(R,m) /\<^sub>R of_nat(R,n) \<ge>\<^sub>R 0\<^sub>R"
@proof @have "of_nat(R,m) \<ge>\<^sub>R 0\<^sub>R" @have "of_nat(R,n) \<ge>\<^sub>R 0\<^sub>R" @qed

lemma ord_field_rat_greater_zero:
  "is_ord_field(R) \<Longrightarrow> m \<in> nat \<Longrightarrow> n \<in> nat \<Longrightarrow> m \<noteq> 0 \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> of_nat(R,m) /\<^sub>R of_nat(R,n) >\<^sub>R 0\<^sub>R"
@proof @have "of_nat(R,m) >\<^sub>R 0\<^sub>R" @have "of_nat(R,n) \<ge>\<^sub>R 0\<^sub>R" @qed

lemma ord_ring_le_switch_left':
  "is_ord_ring(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> 0\<^sub>R \<le>\<^sub>R y -\<^sub>R x \<Longrightarrow> x \<le>\<^sub>R y" by auto2

lemma ord_ring_less_switch_left':
  "is_ord_ring(R) \<Longrightarrow> x \<in>. R \<Longrightarrow> y \<in>. R \<Longrightarrow> 0\<^sub>R <\<^sub>R y -\<^sub>R x \<Longrightarrow> x <\<^sub>R y" by auto2

lemma ord_field_le_to_neg: "is_ord_field(R) \<Longrightarrow> x \<le>\<^sub>R y \<Longrightarrow> \<not>y <\<^sub>R x" by auto2
lemma ord_field_less_to_neg: "is_ord_field(R) \<Longrightarrow> x <\<^sub>R y \<Longrightarrow> \<not>y \<le>\<^sub>R x" by auto2

ML_file "field_steps.ML"

end


section \<open> Expectations \<close>

theory utp_expectation
  imports "UTP.utp"
begin

subsection \<open> Probabilities \<close>

typedef prob = "{0..1} :: real set"
  by auto

setup_lifting type_definition_prob

instantiation prob :: "{ord,zero,one,times,uminus}"
begin
  lift_definition less_eq_prob :: "prob \<Rightarrow> prob \<Rightarrow> bool" is "less_eq" .
  lift_definition less_prob :: "prob \<Rightarrow> prob \<Rightarrow> bool" is "less" .
  lift_definition zero_prob :: prob is 0 by auto
  lift_definition one_prob :: prob is 1 by auto
  lift_definition times_prob :: "prob \<Rightarrow> prob \<Rightarrow> prob" is "times"
    by (auto, simp add: mult_le_one)
  lift_definition uminus_prob :: "prob \<Rightarrow> prob" is "\<lambda> p. 1 - p"
    by (auto)
instance ..
end

instance prob :: order
  by (intro_classes, (transfer, auto)+)

instance prob :: comm_monoid_mult
  by (intro_classes, (transfer, auto)+)

lemma "- (- (p :: prob)) = p"
  by (transfer, simp)

subsection \<open> Expectation Type \<close>

type_synonym '\<alpha> uexpt = "(prob, '\<alpha>) uexpr"

definition upred_expt :: "'\<alpha> upred \<Rightarrow> '\<alpha> uexpt" ("[_]\<^sub>P") where
[upred_defs]: "[P]\<^sub>P = 1 \<triangleleft> P \<triangleright> 0"

lemma upred_expt_false: "[false]\<^sub>P = 0"
  by pred_auto

lemma upred_expt_true: "[true]\<^sub>P = 1"
  by pred_auto

end


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

text {*
Boolean functions (in finitely many variables) can be represented by so-called
{\it binary decision diagrams} (BDDs), which are given by the following data
type:
*}

datatype bdd = Leaf bool | Branch bdd bdd

primrec eval :: "(nat \<Rightarrow> bool) \<Rightarrow> nat \<Rightarrow> bdd \<Rightarrow> bool"
  where "eval f i (Leaf b) = b"
  |"eval f i (Branch x y) = (if (f i) then (eval f (Suc i) y) else ( eval f (Suc i ) x))"

text {*
that evaluates a BDD under a given variable assignment, beginning at a variable
with a given index.
*}

text {*
{\bf Exercise 2:} Define two functions
*}

primrec bdd_unop :: "(bool \<Rightarrow> bool) \<Rightarrow> bdd \<Rightarrow> bdd" where
  "bdd_unop f (Leaf x) = Leaf (f x)"
| "bdd_unop f (Branch b1 b2) = Branch (bdd_unop f b1) (bdd_unop f b2)"

primrec bdd_binop :: "(bool \<Rightarrow> bool \<Rightarrow> bool) \<Rightarrow> bdd \<Rightarrow> bdd \<Rightarrow> bdd" where
  "bdd_binop f (Leaf x) b = bdd_unop (f x) b"
| "bdd_binop f (Branch b1 b2) b = (case b of
       Leaf x \<Rightarrow> Branch (bdd_binop f b1 (Leaf x)) (bdd_binop f b2 (Leaf x))
     | Branch b1' b2' \<Rightarrow> Branch (bdd_binop f b1 b1') (bdd_binop f b2 b2'))"

text {*
for the application of unary and binary operators to BDDs, and prove their
correctness.
*}
theorem bdd_unop_correct:
  "\<forall>i. eval e i (bdd_unop f b) = f (eval e i b)"
  apply (induct b)
   apply auto
  done
theorem bdd_binop_correct:
  "\<forall>i b2. eval e i (bdd_binop f b1 b2) = f (eval e i b1) (eval e i b2)"
  apply (induct b1 )
   apply (auto simp add :bdd_unop_correct)
     apply (case_tac b2)
      apply auto
 apply (case_tac b2)
     apply auto
   apply (case_tac b2)
    apply auto
  apply (case_tac b2)
  apply auto
  done

text {*
Now use @{term "bdd_unop"} and @{term "bdd_binop"} to define
*}

fun
  bdd_and :: "bdd \<Rightarrow> bdd \<Rightarrow> bdd" where
"bdd_and x y = (bdd_binop (\<lambda> x y. x\<and>y) x y)"
fun  bdd_or :: "bdd \<Rightarrow> bdd \<Rightarrow> bdd"where
"bdd_or x y = (bdd_binop (\<lambda> x y. x\<or>y) x y)"
fun  bdd_not :: "bdd \<Rightarrow> bdd"where
"bdd_not x  = (bdd_unop (\<lambda> x . (\<not>x)) x )"
fun  bdd_xor :: "bdd \<Rightarrow> bdd \<Rightarrow> bdd"where
"bdd_xor x y = (bdd_or (bdd_and (bdd_not x) y) (bdd_and x (bdd_not y)))"

text {*
and show correctness.
*}
theorem bdd_and_correct:
  "eval e i (bdd_and b1 b2) = (eval e i b1 \<and> eval e i b2)"
  apply (auto simp add:  bdd_binop_correct)
  done
 theorem bdd_or_correct:
  "eval e i (bdd_or b1 b2) = (eval e i b1 \<or> eval e i b2)"
  apply (auto simp add:  bdd_binop_correct)
  done
  theorem bdd_not_correct:
  "eval e i (bdd_not b) = (\<not>(eval e i b))"
  apply (auto simp add:  bdd_unop_correct)
  done

text {*
Finally, define a function
*}

text {*
to create a BDD that evaluates to @{term "True"} if and only if the variable
with the given index evaluates to @{term "True"}.  Again prove a suitable
correctness theorem.

{\bf Hint:} If a lemma cannot be proven by induction because in the inductive
step a different value is used for a (non-induction) variable than in the
induction hypothesis, it may be necessary to strengthen the lemma by universal
quantification over that variable (cf.\ Section 3.2 in the Tutorial on
Isabelle/HOL).
*}

text_raw {* \begin{minipage}[t]{0.45\textwidth} *}

text{*
{\bf Example:} instead of
*}

lemma "P (b::bdd) x"
apply (induct b) (*<*) oops (*>*)

text_raw {* \end{minipage} *}
text_raw {* \begin{minipage}[t]{0.45\textwidth} *}

text {* Strengthening: *}

lemma "\<forall>x. P (b::bdd) x"
apply (induct b) (*<*) oops (*>*)

text_raw {* \end{minipage} \\[0.5cm]*}
primrec bdd_var :: "nat \<Rightarrow> bdd" where
  "bdd_var 0 = Branch (Leaf False) (Leaf True)"
| "bdd_var (Suc i) = Branch (bdd_var i) (bdd_var i)"

theorem bdd_var_correct: "\<forall>j. eval e j (bdd_var i) = e (i+j)"
  apply (induct i)
  apply auto
done

text {*
{\bf Exercise 3:} Recall the following data type of propositional formulae
(cf.\ the exercise on ``Representation of Propositional Formulae by
Polynomials'')
*}

datatype form = T | Var nat | And form form | Xor form form

text {*
together with the evaluation function @{text "evalf"}:
*}

definition xor :: "bool \<Rightarrow> bool \<Rightarrow> bool" where
  "xor x y \<equiv>  (x \<and> \<not> y) \<or> (\<not> x \<and> y)"

primrec evalf :: "(nat \<Rightarrow> bool) \<Rightarrow> form \<Rightarrow> bool" where
  "evalf e T = True"
| "evalf e (Var i) = e i"
| "evalf e (And f1 f2) = (evalf e f1 \<and> evalf e f2)"
| "evalf e (Xor f1 f2) = xor (evalf e f1) (evalf e f2)"

text {*
Define a function
*}

primrec  mk_bdd :: "form \<Rightarrow> bdd" where
"mk_bdd T = (Leaf True)"
|"mk_bdd (Var i) = (bdd_var i)"
|"mk_bdd (And f1 f2) = bdd_and (mk_bdd f1) (mk_bdd f2)"
|"mk_bdd(Xor f1 f2) = bdd_xor (mk_bdd f1) (mk_bdd f2)"

text {*
that transforms a propositional formula of type @{typ "form"} into a BDD.
Prove the correctness theorem
*}

theorem mk_bdd_correct: "eval e 0 (mk_bdd f) = evalf e f"
  apply (induct f)
 apply (auto simp add: bdd_var_correct
    bdd_and_correct bdd_or_correct bdd_not_correct  xor_def)
       oops

(*<*) end (*>*)


theory List_Group
imports Sort_Descending
begin

section\<open>List Group\<close>

function (sequential) list_group_eq :: "'a list \<Rightarrow> 'a list list" where
  "list_group_eq [] = []" |
  "list_group_eq (x#xs) = [x # takeWhile ((=) x) xs] @ list_group_eq (dropWhile ((=) x) xs)"
by pat_completeness auto
termination list_group_eq
apply (relation "measure (\<lambda>N. length N )")
apply(simp_all add: le_imp_less_Suc length_dropWhile_le)
done

value "list_group_eq [1::int,2,2,2,3,1,4,5,5,5]"

function (sequential) list_group_eq_key :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'a list list" where
  "list_group_eq_key _ [] = []" |
  "list_group_eq_key f (x#xs) = [x # takeWhile (\<lambda>y. f x = f y) xs] @ list_group_eq_key f (dropWhile (\<lambda>y. f x = f y) xs)"
by pat_completeness auto
termination list_group_eq_key
apply (relation "measure (\<lambda>(f,N). length N )")
apply(simp_all add: le_imp_less_Suc length_dropWhile_le)
done

value "list_group_eq_key fst [(1::int, ''''), (2,''a''), (2,''b''), (2, ''c''), (3, ''c''), (1,''''), (4,'''')]"

lemma "list_group_eq_key id xs = list_group_eq xs"
apply(induction xs rule: list_group_eq.induct)
 by(simp_all add: id_def)

(*
lemma "sorted (map f (x#xs)) \<Longrightarrow> list_group_eq_key f (x#xs) = [x # filter (\<lambda>y. f x = f y) xs] @ list_group_eq_key f (filter (\<lambda>y. f x \<noteq> f y) xs)"
  apply(simp)
  oops
lemma "sorted (x#xs) \<Longrightarrow> distinct (list_group_eq_key f (x#xs)) \<Longrightarrow> distinct (list_group_eq_key f xs)"
  apply(induction xs)
   apply(simp)
oops
*)

end


theory Tutorial2_1
imports Main
begin

  section \<open>Arithmetic expressions with side-effects\<close>

  text \<open>Model arithmetic expressions with an assignment operator
    \<open>x:=a\<close>, which assigns the result of \<open>a\<close> to variable \<open>x\<close>, and also
    evaluates to this result. Actually, C and C++ have such assignment
    operators.

    y = (x=(z=5)) + 6

  \<close>

  text \<open>Start over with the syntax tree\<close>
  type_synonym vname = string
  type_synonym val = int
  type_synonym state = "vname \<Rightarrow> val"

  text {* A little syntax magic to write larger states compactly: *}

  definition null_state ("<>") where
    "null_state \<equiv> \<lambda>x. 0"
  syntax
    "_State" :: "updbinds => 'a" ("<_>")
  translations
    "_State ms" == "_Update <> ms"
    "_State (_updbinds b bs)" <= "_Update (_State b) bs"

  datatype aexp = N int | V vname | Assign vname aexp | Plus aexp aexp (* Add assignment operator here *)

  text \<open>The function \<open>aval\<close> now returns a pair of value and new state.
    Use a case distinction (\<open>case \<dots> of (v,s) \<Rightarrow> \<dots>\<close>) or the (equivalent)
    let-syntax for products (\<open>let (v,s) = \<dots> in \<dots>\<close>) to get hands on the
    result value and the state from a pair.
  \<close>
  fun aval :: "aexp \<Rightarrow> state \<Rightarrow> val \<times> state" where
    "aval (N i) s = (i, s)"
  | "aval (V x) s = (s x, s)"
  | "aval (Assign x a) s = (case aval a s of (v, s) \<Rightarrow> (v, s(x:=v)))"
  | "aval (Plus a1 a2) s = (case aval a1 s of (v1,s) \<Rightarrow> case aval a2 s of (v2,s) \<Rightarrow> (v1+v2,s))"

  value "snd (aval (Assign ''x'' (N 5)) <>) ''x''"

  term "let (v1,s) = aval a1 s; (v2,s) = aval a2 s in (v1+v2,s)"

  text \<open>Extend the constant folding to assignments!
    Also consider assignments of the form \<open>x:=x\<close>!

    Do not try to move assignments, i.e., do not try to further optimize
    an expression like \<open>(x := 4) + 7\<close>.
  \<close>

  fun plus :: "aexp \<Rightarrow> aexp \<Rightarrow> aexp" where
    "plus (N x) (N y)  = N (x+y)"
  | "plus (N i) b = (if i=0 then b else Plus (N i) b)"
  | "plus a (N i) = (if i=0 then a else Plus a (N i))"
  | "plus a b = Plus a b"

  fun assign :: "vname \<Rightarrow> aexp \<Rightarrow> aexp" where
    "assign x (V y) = (if x=y then V x else Assign x (V y))"
  | "assign x a = Assign x a"

  lemma aval_plus[simp]: "aval (plus a1 a2) s = aval (Plus a1 a2) s"
    apply (cases "(a1,a2)" rule: plus.cases) apply auto done
    (*
    apply (induction a1 a2 rule: plus.induct)
    apply (auto)
    *)

  lemma aval_assign[simp]: "aval (assign x a) s = aval (Assign x a) s"
    apply (induction x a rule: assign.induct) apply auto done

  (* Prove a similar lemma for assign! *)

  fun asimp :: "aexp \<Rightarrow> aexp" where
    "asimp (N n) =  N n"
  | "asimp (V x) =  V x"
  | "asimp (Assign x a) = assign x (asimp a)"
  | "asimp (Plus a1 a2) = plus (asimp a1) (asimp a2)"

  theorem aval_asimp[simp]: "aval (asimp a) s = aval a s"
    apply (induction a arbitrary: s)
    apply (auto split: prod.splits)
    done

  subsection \<open>Compiling\<close>

  (* Extend the stack machine with a \<open>STORE x\<close> instruction, that
    pops the topmost stack value and stores it to variable \<open>x\<close>.
  *)

  datatype instr = LOADI val | LOAD vname | STORE vname | ADD
  type_synonym stack = "val list"

  (* The execute functions now works on pairs of state and stack. *)
  fun exec1  :: "instr \<Rightarrow> (state \<times> stack) \<Rightarrow> state \<times> stack" where
    "exec1 (LOADI i) (s,stk) = (s, i#stk)"
  | "exec1 (LOAD x) (s,stk) = (s, s x#stk)"
  | "exec1 (STORE x) (s,v#stk) = (s(x:=v), stk)"
  | "exec1 (ADD) (s,v1#v2#stk) = (s, (v1+v2) # stk)"
  | "exec1 _ _ = undefined"

  (* Nothing changes here, I only changed the name to sxstk for \<open>state \<times> stack\<close> *)
  fun exec :: "instr list \<Rightarrow> (state \<times> stack) \<Rightarrow> state \<times> stack" where
  "exec [] sxstk = sxstk" |
  "exec (i#is) sxstk = exec is (exec1 i sxstk)"

  lemma exec_append[simp]:
    "exec (is1@is2) sxstk = exec is2 (exec is1 sxstk)"
    apply (induction is1 arbitrary: sxstk)
    apply auto
    done

  (* Compile arithmetic expressions with assignment, and show compiler correctness *)
  hide_const (open) comp

  fun comp :: "aexp \<Rightarrow> instr list" where
    "comp (N i) = [LOADI i]"
  | "comp (V x) = [LOAD x]"
  | "comp (Assign x a) = comp a @ [STORE x, LOAD x]"
  | "comp (Plus a1 a2) = comp a1 @ comp a2 @ [ADD]"

  (* Hint: For assignment, a simple way is to LOAD the variable after one has STOREd it *)

  (* We phrased the theorem to be easily provable.
    It is generally a good idea to write pairs explicitly,
    instead of accessing them with \<open>fst, snd\<close> etc.
  *)
  theorem exec_comp:
    "aval a s = (v,s') \<Longrightarrow> exec (comp a) (s,stk) = (s',v#stk)"
    apply (induction a arbitrary: v s' s stk)
    apply (auto split: prod.splits)
    done

    (* Hint: Quite a lot of variables have to be generalized over (arbitrary).
      Use \<open>split: prod.splits\<close> to automatically split over case-distinctions
      on pairs.
    *)

end