(*  Title:      HOL/Library/Finite_Lattice.thy
    Author:     Alessandro Coglio
*)

theory Finite_Lattice
imports Product_Order
begin

text {* A non-empty finite lattice is a complete lattice.
Since types are never empty in Isabelle/HOL,
a type of classes @{class finite} and @{class lattice}
should also have class @{class complete_lattice}.
A type class is defined
that extends classes @{class finite} and @{class lattice}
with the operators @{const bot}, @{const top}, @{const Inf}, and @{const Sup},
along with assumptions that define these operators
in terms of the ones of classes @{class finite} and @{class lattice}.
The resulting class is a subclass of @{class complete_lattice}. *}

class finite_lattice_complete = finite + lattice + bot + top + Inf + Sup +
  assumes bot_def: "bot = Inf_fin UNIV"
  assumes top_def: "top = Sup_fin UNIV"
  assumes Inf_def: "Inf A = Finite_Set.fold inf top A"
  assumes Sup_def: "Sup A = Finite_Set.fold sup bot A"

text {* The definitional assumptions
on the operators @{const bot} and @{const top}
of class @{class finite_lattice_complete}
ensure that they yield bottom and top. *}

lemma finite_lattice_complete_bot_least: "(bot::'a::finite_lattice_complete) \<le> x"
  by (auto simp: bot_def intro: Inf_fin.coboundedI)

instance finite_lattice_complete \<subseteq> order_bot
  by default (auto simp: finite_lattice_complete_bot_least)

lemma finite_lattice_complete_top_greatest: "(top::'a::finite_lattice_complete) \<ge> x"
  by (auto simp: top_def Sup_fin.coboundedI)

instance finite_lattice_complete \<subseteq> order_top
  by default (auto simp: finite_lattice_complete_top_greatest)

instance finite_lattice_complete \<subseteq> bounded_lattice ..

text {* The definitional assumptions
on the operators @{const Inf} and @{const Sup}
of class @{class finite_lattice_complete}
ensure that they yield infimum and supremum. *}

lemma finite_lattice_complete_Inf_empty: "Inf {} = (top :: 'a::finite_lattice_complete)"
  by (simp add: Inf_def)

lemma finite_lattice_complete_Sup_empty: "Sup {} = (bot :: 'a::finite_lattice_complete)"
  by (simp add: Sup_def)

lemma finite_lattice_complete_Inf_insert:
  fixes A :: "'a::finite_lattice_complete set"
  shows "Inf (insert x A) = inf x (Inf A)"
proof -
  interpret comp_fun_idem "inf :: 'a \<Rightarrow> _"
    by (fact comp_fun_idem_inf)
  show ?thesis by (simp add: Inf_def)
qed

lemma finite_lattice_complete_Sup_insert:
  fixes A :: "'a::finite_lattice_complete set"
  shows "Sup (insert x A) = sup x (Sup A)"
proof -
  interpret comp_fun_idem "sup :: 'a \<Rightarrow> _"
    by (fact comp_fun_idem_sup)
  show ?thesis by (simp add: Sup_def)
qed

lemma finite_lattice_complete_Inf_lower:
  "(x::'a::finite_lattice_complete) \<in> A \<Longrightarrow> Inf A \<le> x"
  using finite [of A]
  by (induct A) (auto simp add: finite_lattice_complete_Inf_insert intro: le_infI2)

lemma finite_lattice_complete_Inf_greatest:
  "\<forall>x::'a::finite_lattice_complete \<in> A. z \<le> x \<Longrightarrow> z \<le> Inf A"
  using finite [of A]
  by (induct A) (auto simp add: finite_lattice_complete_Inf_empty finite_lattice_complete_Inf_insert)

lemma finite_lattice_complete_Sup_upper:
  "(x::'a::finite_lattice_complete) \<in> A \<Longrightarrow> Sup A \<ge> x"
  using finite [of A]
  by (induct A) (auto simp add: finite_lattice_complete_Sup_insert intro: le_supI2)

lemma finite_lattice_complete_Sup_least:
  "\<forall>x::'a::finite_lattice_complete \<in> A. z \<ge> x \<Longrightarrow> z \<ge> Sup A"
  using finite [of A]
  by (induct A) (auto simp add: finite_lattice_complete_Sup_empty finite_lattice_complete_Sup_insert)

instance finite_lattice_complete \<subseteq> complete_lattice
proof
qed (auto simp:
  finite_lattice_complete_Inf_lower
  finite_lattice_complete_Inf_greatest
  finite_lattice_complete_Sup_upper
  finite_lattice_complete_Sup_least
  finite_lattice_complete_Inf_empty
  finite_lattice_complete_Sup_empty)

text {* The product of two finite lattices is already a finite lattice. *}

lemma finite_bot_prod:
  "(bot :: ('a::finite_lattice_complete \<times> 'b::finite_lattice_complete)) =
    Inf_fin UNIV"
  by (metis Inf_fin.coboundedI UNIV_I bot.extremum_uniqueI finite_UNIV)

lemma finite_top_prod:
  "(top :: ('a::finite_lattice_complete \<times> 'b::finite_lattice_complete)) =
    Sup_fin UNIV"
  by (metis Sup_fin.coboundedI UNIV_I top.extremum_uniqueI finite_UNIV)

lemma finite_Inf_prod:
  "Inf(A :: ('a::finite_lattice_complete \<times> 'b::finite_lattice_complete) set) =
    Finite_Set.fold inf top A"
  by (metis Inf_fold_inf finite_code)

lemma finite_Sup_prod:
  "Sup (A :: ('a::finite_lattice_complete \<times> 'b::finite_lattice_complete) set) =
    Finite_Set.fold sup bot A"
  by (metis Sup_fold_sup finite_code)

instance prod :: (finite_lattice_complete, finite_lattice_complete) finite_lattice_complete
  by default (auto simp: finite_bot_prod finite_top_prod finite_Inf_prod finite_Sup_prod)

text {* Functions with a finite domain and with a finite lattice as codomain
already form a finite lattice. *}

lemma finite_bot_fun: "(bot :: ('a::finite \<Rightarrow> 'b::finite_lattice_complete)) = Inf_fin UNIV"
  by (metis Inf_UNIV Inf_fin_Inf empty_not_UNIV finite_code)

lemma finite_top_fun: "(top :: ('a::finite \<Rightarrow> 'b::finite_lattice_complete)) = Sup_fin UNIV"
  by (metis Sup_UNIV Sup_fin_Sup empty_not_UNIV finite_code)

lemma finite_Inf_fun:
  "Inf (A::('a::finite \<Rightarrow> 'b::finite_lattice_complete) set) =
    Finite_Set.fold inf top A"
  by (metis Inf_fold_inf finite_code)

lemma finite_Sup_fun:
  "Sup (A::('a::finite \<Rightarrow> 'b::finite_lattice_complete) set) =
    Finite_Set.fold sup bot A"
  by (metis Sup_fold_sup finite_code)

instance "fun" :: (finite, finite_lattice_complete) finite_lattice_complete
  by default (auto simp: finite_bot_fun finite_top_fun finite_Inf_fun finite_Sup_fun)

subsection {* Finite Distributive Lattices *}

text {* A finite distributive lattice is a complete lattice
whose @{const inf} and @{const sup} operators
distribute over @{const Sup} and @{const Inf}. *}

class finite_distrib_lattice_complete =
  distrib_lattice + finite_lattice_complete

lemma finite_distrib_lattice_complete_sup_Inf:
  "sup (x::'a::finite_distrib_lattice_complete) (Inf A) = (INF y:A. sup x y)"
  using finite
  by (induct A rule: finite_induct) (simp_all add: sup_inf_distrib1)

lemma finite_distrib_lattice_complete_inf_Sup:
  "inf (x::'a::finite_distrib_lattice_complete) (Sup A) = (SUP y:A. inf x y)"
  apply (rule finite_induct)
  apply (metis finite_code)
  apply (metis SUP_empty Sup_empty inf_bot_right)
  apply (metis SUP_insert Sup_insert inf_sup_distrib1)
  done

instance finite_distrib_lattice_complete \<subseteq> complete_distrib_lattice
proof
qed (auto simp:
  finite_distrib_lattice_complete_sup_Inf
  finite_distrib_lattice_complete_inf_Sup)

text {* The product of two finite distributive lattices
is already a finite distributive lattice. *}

instance prod ::
  (finite_distrib_lattice_complete, finite_distrib_lattice_complete)
  finite_distrib_lattice_complete
  ..

text {* Functions with a finite domain
and with a finite distributive lattice as codomain
already form a finite distributive lattice. *}

instance "fun" ::
  (finite, finite_distrib_lattice_complete) finite_distrib_lattice_complete
  ..

subsection {* Linear Orders *}

text {* A linear order is a distributive lattice.
A type class is defined
that extends class @{class linorder}
with the operators @{const inf} and @{const sup},
along with assumptions that define these operators
in terms of the ones of class @{class linorder}.
The resulting class is a subclass of @{class distrib_lattice}. *}

class linorder_lattice = linorder + inf + sup +
  assumes inf_def: "inf x y = (if x \<le> y then x else y)"
  assumes sup_def: "sup x y = (if x \<ge> y then x else y)"

text {* The definitional assumptions
on the operators @{const inf} and @{const sup}
of class @{class linorder_lattice}
ensure that they yield infimum and supremum
and that they distribute over each other. *}

lemma linorder_lattice_inf_le1: "inf (x::'a::linorder_lattice) y \<le> x"
  unfolding inf_def by (metis (full_types) linorder_linear)

lemma linorder_lattice_inf_le2: "inf (x::'a::linorder_lattice) y \<le> y"
  unfolding inf_def by (metis (full_types) linorder_linear)

lemma linorder_lattice_inf_greatest:
  "(x::'a::linorder_lattice) \<le> y \<Longrightarrow> x \<le> z \<Longrightarrow> x \<le> inf y z"
  unfolding inf_def by (metis (full_types))

lemma linorder_lattice_sup_ge1: "sup (x::'a::linorder_lattice) y \<ge> x"
  unfolding sup_def by (metis (full_types) linorder_linear)

lemma linorder_lattice_sup_ge2: "sup (x::'a::linorder_lattice) y \<ge> y"
  unfolding sup_def by (metis (full_types) linorder_linear)

lemma linorder_lattice_sup_least:
  "(x::'a::linorder_lattice) \<ge> y \<Longrightarrow> x \<ge> z \<Longrightarrow> x \<ge> sup y z"
  by (auto simp: sup_def)

lemma linorder_lattice_sup_inf_distrib1:
  "sup (x::'a::linorder_lattice) (inf y z) = inf (sup x y) (sup x z)"
  by (auto simp: inf_def sup_def)

instance linorder_lattice \<subseteq> distrib_lattice
proof
qed (auto simp:
  linorder_lattice_inf_le1
  linorder_lattice_inf_le2
  linorder_lattice_inf_greatest
  linorder_lattice_sup_ge1
  linorder_lattice_sup_ge2
  linorder_lattice_sup_least
  linorder_lattice_sup_inf_distrib1)

subsection {* Finite Linear Orders *}

text {* A (non-empty) finite linear order is a complete linear order. *}

class finite_linorder_complete = linorder_lattice + finite_lattice_complete

instance finite_linorder_complete \<subseteq> complete_linorder ..

text {* A (non-empty) finite linear order is a complete lattice
whose @{const inf} and @{const sup} operators
distribute over @{const Sup} and @{const Inf}. *}

instance finite_linorder_complete \<subseteq> finite_distrib_lattice_complete ..

end


(*  Title:      HOL/Library/Ramsey.thy
    Author:     Tom Ridge.  Converted to structured Isar by L C Paulson
*)

section "Ramsey's Theorem"

theory Ramsey
imports Main Infinite_Set
begin

subsection{* Finite Ramsey theorem(s) *}

text{* To distinguish the finite and infinite ones, lower and upper case
names are used.

This is the most basic version in terms of cliques and independent
sets, i.e. the version for graphs and 2 colours. *}

definition "clique V E = (\<forall>v\<in>V. \<forall>w\<in>V. v\<noteq>w \<longrightarrow> {v,w} : E)"
definition "indep V E = (\<forall>v\<in>V. \<forall>w\<in>V. v\<noteq>w \<longrightarrow> \<not> {v,w} : E)"

lemma ramsey2:
  "\<exists>r\<ge>1. \<forall> (V::'a set) (E::'a set set). finite V \<and> card V \<ge> r \<longrightarrow>
  (\<exists> R \<subseteq> V. card R = m \<and> clique R E \<or> card R = n \<and> indep R E)"
  (is "\<exists>r\<ge>1. ?R m n r")
proof(induct k == "m+n" arbitrary: m n)
  case 0
  show ?case (is "EX r. ?R r")
  proof
    show "?R 1" using 0
      by (clarsimp simp: indep_def)(metis card.empty emptyE empty_subsetI)
  qed
next
  case (Suc k)
  { assume "m=0"
    have ?case (is "EX r. ?R r")
    proof
      show "?R 1" using `m=0`
        by (simp add:clique_def)(metis card.empty emptyE empty_subsetI)
    qed
  } moreover
  { assume "n=0"
    have ?case (is "EX r. ?R r")
    proof
      show "?R 1" using `n=0`
        by (simp add:indep_def)(metis card.empty emptyE empty_subsetI)
    qed
  } moreover
  { assume "m\<noteq>0" "n\<noteq>0"
    then have "k = (m - 1) + n" "k = m + (n - 1)" using `Suc k = m+n` by auto
    from Suc(1)[OF this(1)] Suc(1)[OF this(2)]
    obtain r1 r2 where "r1\<ge>1" "r2\<ge>1" "?R (m - 1) n r1" "?R m (n - 1) r2"
      by auto
    then have "r1+r2 \<ge> 1" by arith
    moreover
    have "?R m n (r1+r2)" (is "ALL V E. _ \<longrightarrow> ?EX V E m n")
    proof clarify
      fix V :: "'a set" and E :: "'a set set"
      assume "finite V" "r1+r2 \<le> card V"
      with `r1\<ge>1` have "V \<noteq> {}" by auto
      then obtain v where "v : V" by blast
      let ?M = "{w : V. w\<noteq>v & {v,w} : E}"
      let ?N = "{w : V. w\<noteq>v & {v,w} ~: E}"
      have "V = insert v (?M \<union> ?N)" using `v : V` by auto
      then have "card V = card(insert v (?M \<union> ?N))" by metis
      also have "\<dots> = card ?M + card ?N + 1" using `finite V`
        by(fastforce intro: card_Un_disjoint)
      finally have "card V = card ?M + card ?N + 1" .
      then have "r1+r2 \<le> card ?M + card ?N + 1" using `r1+r2 \<le> card V` by simp
      then have "r1 \<le> card ?M \<or> r2 \<le> card ?N" by arith
      moreover
      { assume "r1 \<le> card ?M"
        moreover have "finite ?M" using `finite V` by auto
        ultimately have "?EX ?M E (m - 1) n" using `?R (m - 1) n r1` by blast
        then obtain R where "R \<subseteq> ?M" "v ~: R" and
          CI: "card R = m - 1 \<and> clique R E \<or>
               card R = n \<and> indep R E" (is "?C \<or> ?I")
          by blast
        have "R <= V" using `R <= ?M` by auto
        have "finite R" using `finite V` `R \<subseteq> V` by (metis finite_subset)
        { assume "?I"
          with `R <= V` have "?EX V E m n" by blast
        } moreover
        { assume "?C"
          then have "clique (insert v R) E" using `R <= ?M`
           by(auto simp:clique_def insert_commute)
          moreover have "card(insert v R) = m"
            using `?C` `finite R` `v ~: R` `m\<noteq>0` by simp
          ultimately have "?EX V E m n" using `R <= V` `v : V` by blast
        } ultimately have "?EX V E m n" using CI by blast
      } moreover
      { assume "r2 \<le> card ?N"
        moreover have "finite ?N" using `finite V` by auto
        ultimately have "?EX ?N E m (n - 1)" using `?R m (n - 1) r2` by blast
        then obtain R where "R \<subseteq> ?N" "v ~: R" and
          CI: "card R = m \<and> clique R E \<or>
               card R = n - 1 \<and> indep R E" (is "?C \<or> ?I")
          by blast
        have "R <= V" using `R <= ?N` by auto
        have "finite R" using `finite V` `R \<subseteq> V` by (metis finite_subset)
        { assume "?C"
          with `R <= V` have "?EX V E m n" by blast
        } moreover
        { assume "?I"
          then have "indep (insert v R) E" using `R <= ?N`
            by(auto simp:indep_def insert_commute)
          moreover have "card(insert v R) = n"
            using `?I` `finite R` `v ~: R` `n\<noteq>0` by simp
          ultimately have "?EX V E m n" using `R <= V` `v : V` by blast
        } ultimately have "?EX V E m n" using CI by blast
      } ultimately show "?EX V E m n" by blast
    qed
    ultimately have ?case by blast
  } ultimately show ?case by blast
qed

subsection {* Preliminaries *}

subsubsection {* ``Axiom'' of Dependent Choice *}

primrec choice :: "('a => bool) => ('a * 'a) set => nat => 'a" where
  --{*An integer-indexed chain of choices*}
    choice_0:   "choice P r 0 = (SOME x. P x)"
  | choice_Suc: "choice P r (Suc n) = (SOME y. P y & (choice P r n, y) \<in> r)"

lemma choice_n:
  assumes P0: "P x0"
      and Pstep: "!!x. P x ==> \<exists>y. P y & (x,y) \<in> r"
  shows "P (choice P r n)"
proof (induct n)
  case 0 show ?case by (force intro: someI P0)
next
  case Suc then show ?case by (auto intro: someI2_ex [OF Pstep])
qed

lemma dependent_choice:
  assumes trans: "trans r"
      and P0: "P x0"
      and Pstep: "!!x. P x ==> \<exists>y. P y & (x,y) \<in> r"
  obtains f :: "nat => 'a" where
    "!!n. P (f n)" and "!!n m. n < m ==> (f n, f m) \<in> r"
proof
  fix n
  show "P (choice P r n)" by (blast intro: choice_n [OF P0 Pstep])
next
  have PSuc: "\<forall>n. (choice P r n, choice P r (Suc n)) \<in> r"
    using Pstep [OF choice_n [OF P0 Pstep]]
    by (auto intro: someI2_ex)
  fix n m :: nat
  assume less: "n < m"
  show "(choice P r n, choice P r m) \<in> r" using PSuc
    by (auto intro: less_Suc_induct [OF less] transD [OF trans])
qed

subsubsection {* Partitions of a Set *}

definition part :: "nat => nat => 'a set => ('a set => nat) => bool"
  --{*the function @{term f} partitions the @{term r}-subsets of the typically
       infinite set @{term Y} into @{term s} distinct categories.*}
where
  "part r s Y f = (\<forall>X. X \<subseteq> Y & finite X & card X = r --> f X < s)"

text{*For induction, we decrease the value of @{term r} in partitions.*}
lemma part_Suc_imp_part:
     "[| infinite Y; part (Suc r) s Y f; y \<in> Y |]
      ==> part r s (Y - {y}) (%u. f (insert y u))"
  apply(simp add: part_def, clarify)
  apply(drule_tac x="insert y X" in spec)
  apply(force)
  done

lemma part_subset: "part r s YY f ==> Y \<subseteq> YY ==> part r s Y f"
  unfolding part_def by blast

subsection {* Ramsey's Theorem: Infinitary Version *}

lemma Ramsey_induction:
  fixes s and r::nat
  shows
  "!!(YY::'a set) (f::'a set => nat).
      [|infinite YY; part r s YY f|]
      ==> \<exists>Y' t'. Y' \<subseteq> YY & infinite Y' & t' < s &
                  (\<forall>X. X \<subseteq> Y' & finite X & card X = r --> f X = t')"
proof (induct r)
  case 0
  then show ?case by (auto simp add: part_def card_eq_0_iff cong: conj_cong)
next
  case (Suc r)
  show ?case
  proof -
    from Suc.prems infinite_imp_nonempty obtain yy where yy: "yy \<in> YY" by blast
    let ?ramr = "{((y,Y,t),(y',Y',t')). y' \<in> Y & Y' \<subseteq> Y}"
    let ?propr = "%(y,Y,t).
                 y \<in> YY & y \<notin> Y & Y \<subseteq> YY & infinite Y & t < s
                 & (\<forall>X. X\<subseteq>Y & finite X & card X = r --> (f o insert y) X = t)"
    have infYY': "infinite (YY-{yy})" using Suc.prems by auto
    have partf': "part r s (YY - {yy}) (f \<circ> insert yy)"
      by (simp add: o_def part_Suc_imp_part yy Suc.prems)
    have transr: "trans ?ramr" by (force simp add: trans_def)
    from Suc.hyps [OF infYY' partf']
    obtain Y0 and t0
    where "Y0 \<subseteq> YY - {yy}"  "infinite Y0"  "t0 < s"
          "\<forall>X. X\<subseteq>Y0 \<and> finite X \<and> card X = r \<longrightarrow> (f \<circ> insert yy) X = t0"
        by blast
    with yy have propr0: "?propr(yy,Y0,t0)" by blast
    have proprstep: "\<And>x. ?propr x \<Longrightarrow> \<exists>y. ?propr y \<and> (x, y) \<in> ?ramr"
    proof -
      fix x
      assume px: "?propr x" then show "?thesis x"
      proof (cases x)
        case (fields yx Yx tx)
        then obtain yx' where yx': "yx' \<in> Yx" using px
               by (blast dest: infinite_imp_nonempty)
        have infYx': "infinite (Yx-{yx'})" using fields px by auto
        with fields px yx' Suc.prems
        have partfx': "part r s (Yx - {yx'}) (f \<circ> insert yx')"
          by (simp add: o_def part_Suc_imp_part part_subset [where YY=YY and Y=Yx])
        from Suc.hyps [OF infYx' partfx']
        obtain Y' and t'
        where Y': "Y' \<subseteq> Yx - {yx'}"  "infinite Y'"  "t' < s"
               "\<forall>X. X\<subseteq>Y' \<and> finite X \<and> card X = r \<longrightarrow> (f \<circ> insert yx') X = t'"
            by blast
        show ?thesis
        proof
          show "?propr (yx',Y',t') & (x, (yx',Y',t')) \<in> ?ramr"
            using fields Y' yx' px by blast
        qed
      qed
    qed
    from dependent_choice [OF transr propr0 proprstep]
    obtain g where pg: "!!n::nat.  ?propr (g n)"
      and rg: "!!n m. n<m ==> (g n, g m) \<in> ?ramr" by blast
    let ?gy = "fst o g"
    let ?gt = "snd o snd o g"
    have rangeg: "\<exists>k. range ?gt \<subseteq> {..<k}"
    proof (intro exI subsetI)
      fix x
      assume "x \<in> range ?gt"
      then obtain n where "x = ?gt n" ..
      with pg [of n] show "x \<in> {..<s}" by (cases "g n") auto
    qed
    have "finite (range ?gt)"
      by (simp add: finite_nat_iff_bounded rangeg)
    then obtain s' and n'
      where s': "s' = ?gt n'"
        and infeqs': "infinite {n. ?gt n = s'}"
      by (rule inf_img_fin_domE) (auto simp add: vimage_def intro: infinite_UNIV_nat)
    with pg [of n'] have less': "s'<s" by (cases "g n'") auto
    have inj_gy: "inj ?gy"
    proof (rule linorder_injI)
      fix m m' :: nat assume less: "m < m'" show "?gy m \<noteq> ?gy m'"
        using rg [OF less] pg [of m] by (cases "g m", cases "g m'") auto
    qed
    show ?thesis
    proof (intro exI conjI)
      show "?gy ` {n. ?gt n = s'} \<subseteq> YY" using pg
        by (auto simp add: Let_def split_beta)
      show "infinite (?gy ` {n. ?gt n = s'})" using infeqs'
        by (blast intro: inj_gy [THEN subset_inj_on] dest: finite_imageD)
      show "s' < s" by (rule less')
      show "\<forall>X. X \<subseteq> ?gy ` {n. ?gt n = s'} & finite X & card X = Suc r
          --> f X = s'"
      proof -
        {fix X
         assume "X \<subseteq> ?gy ` {n. ?gt n = s'}"
            and cardX: "finite X" "card X = Suc r"
         then obtain AA where AA: "AA \<subseteq> {n. ?gt n = s'}" and Xeq: "X = ?gy`AA"
             by (auto simp add: subset_image_iff)
         with cardX have "AA\<noteq>{}" by auto
         then have AAleast: "(LEAST x. x \<in> AA) \<in> AA" by (auto intro: LeastI_ex)
         have "f X = s'"
         proof (cases "g (LEAST x. x \<in> AA)")
           case (fields ya Ya ta)
           with AAleast Xeq
           have ya: "ya \<in> X" by (force intro!: rev_image_eqI)
           then have "f X = f (insert ya (X - {ya}))" by (simp add: insert_absorb)
           also have "... = ta"
           proof -
             have "X - {ya} \<subseteq> Ya"
             proof
               fix x assume x: "x \<in> X - {ya}"
               then obtain a' where xeq: "x = ?gy a'" and a': "a' \<in> AA"
                 by (auto simp add: Xeq)
               then have "a' \<noteq> (LEAST x. x \<in> AA)" using x fields by auto
               then have lessa': "(LEAST x. x \<in> AA) < a'"
                 using Least_le [of "%x. x \<in> AA", OF a'] by arith
               show "x \<in> Ya" using xeq fields rg [OF lessa'] by auto
             qed
             moreover
             have "card (X - {ya}) = r"
               by (simp add: cardX ya)
             ultimately show ?thesis
               using pg [of "LEAST x. x \<in> AA"] fields cardX
               by (clarsimp simp del:insert_Diff_single)
           qed
           also have "... = s'" using AA AAleast fields by auto
           finally show ?thesis .
         qed}
        then show ?thesis by blast
      qed
    qed
  qed
qed

theorem Ramsey:
  fixes s r :: nat and Z::"'a set" and f::"'a set => nat"
  shows
   "[|infinite Z;
      \<forall>X. X \<subseteq> Z & finite X & card X = r --> f X < s|]
  ==> \<exists>Y t. Y \<subseteq> Z & infinite Y & t < s
            & (\<forall>X. X \<subseteq> Y & finite X & card X = r --> f X = t)"
by (blast intro: Ramsey_induction [unfolded part_def])

corollary Ramsey2:
  fixes s::nat and Z::"'a set" and f::"'a set => nat"
  assumes infZ: "infinite Z"
      and part: "\<forall>x\<in>Z. \<forall>y\<in>Z. x\<noteq>y --> f{x,y} < s"
  shows
   "\<exists>Y t. Y \<subseteq> Z & infinite Y & t < s & (\<forall>x\<in>Y. \<forall>y\<in>Y. x\<noteq>y --> f{x,y} = t)"
proof -
  have part2: "\<forall>X. X \<subseteq> Z & finite X & card X = 2 --> f X < s"
    using part by (fastforce simp add: eval_nat_numeral card_Suc_eq)
  obtain Y t
    where *: "Y \<subseteq> Z" "infinite Y" "t < s"
          "(\<forall>X. X \<subseteq> Y & finite X & card X = 2 --> f X = t)"
    by (insert Ramsey [OF infZ part2]) auto
  then have "\<forall>x\<in>Y. \<forall>y\<in>Y. x \<noteq> y \<longrightarrow> f {x, y} = t" by auto
  with * show ?thesis by iprover
qed

subsection {* Disjunctive Well-Foundedness *}

text {*
  An application of Ramsey's theorem to program termination. See
  @{cite "Podelski-Rybalchenko"}.
*}

definition disj_wf :: "('a * 'a)set => bool"
  where "disj_wf r = (\<exists>T. \<exists>n::nat. (\<forall>i<n. wf(T i)) & r = (\<Union>i<n. T i))"

definition transition_idx :: "[nat => 'a, nat => ('a*'a)set, nat set] => nat"
  where
    "transition_idx s T A =
      (LEAST k. \<exists>i j. A = {i,j} & i<j & (s j, s i) \<in> T k)"

lemma transition_idx_less:
    "[|i<j; (s j, s i) \<in> T k; k<n|] ==> transition_idx s T {i,j} < n"
apply (subgoal_tac "transition_idx s T {i, j} \<le> k", simp)
apply (simp add: transition_idx_def, blast intro: Least_le)
done

lemma transition_idx_in:
    "[|i<j; (s j, s i) \<in> T k|] ==> (s j, s i) \<in> T (transition_idx s T {i,j})"
apply (simp add: transition_idx_def doubleton_eq_iff conj_disj_distribR
            cong: conj_cong)
apply (erule LeastI)
done

text{*To be equal to the union of some well-founded relations is equivalent
to being the subset of such a union.*}
lemma disj_wf:
     "disj_wf(r) = (\<exists>T. \<exists>n::nat. (\<forall>i<n. wf(T i)) & r \<subseteq> (\<Union>i<n. T i))"
apply (auto simp add: disj_wf_def)
apply (rule_tac x="%i. T i Int r" in exI)
apply (rule_tac x=n in exI)
apply (force simp add: wf_Int1)
done

theorem trans_disj_wf_implies_wf:
  assumes transr: "trans r"
      and dwf:    "disj_wf(r)"
  shows "wf r"
proof (simp only: wf_iff_no_infinite_down_chain, rule notI)
  assume "\<exists>s. \<forall>i. (s (Suc i), s i) \<in> r"
  then obtain s where sSuc: "\<forall>i. (s (Suc i), s i) \<in> r" ..
  have s: "!!i j. i < j ==> (s j, s i) \<in> r"
  proof -
    fix i and j::nat
    assume less: "i<j"
    then show "(s j, s i) \<in> r"
    proof (rule less_Suc_induct)
      show "\<And>i. (s (Suc i), s i) \<in> r" by (simp add: sSuc)
      show "\<And>i j k. \<lbrakk>(s j, s i) \<in> r; (s k, s j) \<in> r\<rbrakk> \<Longrightarrow> (s k, s i) \<in> r"
        using transr by (unfold trans_def, blast)
    qed
  qed
  from dwf
  obtain T and n::nat where wfT: "\<forall>k<n. wf(T k)" and r: "r = (\<Union>k<n. T k)"
    by (auto simp add: disj_wf_def)
  have s_in_T: "\<And>i j. i<j ==> \<exists>k. (s j, s i) \<in> T k & k<n"
  proof -
    fix i and j::nat
    assume less: "i<j"
    then have "(s j, s i) \<in> r" by (rule s [of i j])
    then show "\<exists>k. (s j, s i) \<in> T k & k<n" by (auto simp add: r)
  qed
  have trless: "!!i j. i\<noteq>j ==> transition_idx s T {i,j} < n"
    apply (auto simp add: linorder_neq_iff)
    apply (blast dest: s_in_T transition_idx_less)
    apply (subst insert_commute)
    apply (blast dest: s_in_T transition_idx_less)
    done
  have
   "\<exists>K k. K \<subseteq> UNIV & infinite K & k < n &
          (\<forall>i\<in>K. \<forall>j\<in>K. i\<noteq>j --> transition_idx s T {i,j} = k)"
    by (rule Ramsey2) (auto intro: trless infinite_UNIV_nat)
  then obtain K and k
    where infK: "infinite K" and less: "k < n" and
          allk: "\<forall>i\<in>K. \<forall>j\<in>K. i\<noteq>j --> transition_idx s T {i,j} = k"
    by auto
  have "\<forall>m. (s (enumerate K (Suc m)), s(enumerate K m)) \<in> T k"
  proof
    fix m::nat
    let ?j = "enumerate K (Suc m)"
    let ?i = "enumerate K m"
    have jK: "?j \<in> K" by (simp add: enumerate_in_set infK)
    have iK: "?i \<in> K" by (simp add: enumerate_in_set infK)
    have ij: "?i < ?j" by (simp add: enumerate_step infK)
    have ijk: "transition_idx s T {?i,?j} = k" using iK jK ij
      by (simp add: allk)
    obtain k' where "(s ?j, s ?i) \<in> T k'" "k'<n"
      using s_in_T [OF ij] by blast
    then show "(s ?j, s ?i) \<in> T k"
      by (simp add: ijk [symmetric] transition_idx_in ij)
  qed
  then have "~ wf(T k)" by (force simp add: wf_iff_no_infinite_down_chain)
  then show False using wfT less by blast
qed

end


theory sort_NMSortTDIsSort
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun take :: "Nat => 'a list => 'a list" where
"take (Z) y = Nil2"
| "take (S z) (Nil2) = Nil2"
| "take (S z) (Cons2 x2 x3) = Cons2 x2 (take z x3)"

fun lmerge :: "int list => int list => int list" where
"lmerge (Nil2) y = y"
| "lmerge (Cons2 z x2) (Nil2) = Cons2 z x2"
| "lmerge (Cons2 z x2) (Cons2 x3 x4) =
     (if z <= x3 then Cons2 z (lmerge x2 (Cons2 x3 x4)) else
        Cons2 x3 (lmerge (Cons2 z x2) x4))"

fun length :: "'t list => Nat" where
"length (Nil2) = Z"
| "length (Cons2 y xs) = S (length xs)"

fun insert2 :: "int => int list => int list" where
"insert2 x (Nil2) = Cons2 x (Nil2)"
| "insert2 x (Cons2 z xs) =
     (if x <= z then Cons2 x (Cons2 z xs) else Cons2 z (insert2 x xs))"

fun isort :: "int list => int list" where
"isort (Nil2) = Nil2"
| "isort (Cons2 y xs) = insert2 y (isort xs)"

fun half :: "Nat => Nat" where
"half (Z) = Z"
| "half (S (Z)) = Z"
| "half (S (S n)) = S (half n)"

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 nmsorttd :: "int list => int list" where
"nmsorttd (Nil2) = Nil2"
| "nmsorttd (Cons2 y (Nil2)) = Cons2 y (Nil2)"
| "nmsorttd (Cons2 y (Cons2 x2 x3)) =
     lmerge
       (nmsorttd
          (take
             (half (length (Cons2 y (Cons2 x2 x3)))) (Cons2 y (Cons2 x2 x3))))
       (nmsorttd
          (drop
             (half (length (Cons2 y (Cons2 x2 x3)))) (Cons2 y (Cons2 x2 x3))))"

(*hipster take lmerge length insert2 isort half drop nmsorttd *)

theorem x0 :
  "!! (x :: int list) . (nmsorttd x) = (isort x)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


theory a2
imports Main
begin

section "Part 1"

datatype condition =
  Above nat nat | Joinable nat nat

inductive_set connection :: "condition set \<Rightarrow> condition set"
  for A :: "condition set" where
  con_refl:
    "Above a a \<in> connection A"
| con_in:
    "\<phi> \<in> A \<Longrightarrow> \<phi> \<in> connection A"
| con_mirror:
    "Joinable a b \<in> connection A
     \<Longrightarrow> Joinable b a \<in> connection A"
| con_trans:
    "\<lbrakk>Above a b \<in> connection A;
      Above b c \<in> connection A\<rbrakk>
     \<Longrightarrow> Above a c \<in> connection A"
| con_join:
    "\<lbrakk>Above a b \<in> connection A;
      Above c b \<in> connection A\<rbrakk>
     \<Longrightarrow> Joinable a c \<in> connection A"
| con_ext_join:
    "\<lbrakk>Above a b \<in> connection A;
      Joinable b c \<in> connection A\<rbrakk>
     \<Longrightarrow> Joinable a c \<in> connection A"

primrec is_refl :: "_" where
  "is_refl(Above a b) = (a = b)"
| "is_refl(Joinable a b) = (a = b)"

section "Question 1 (a)"

definition router1
  where "router1= 0"
definition router2
  where "router2= 1"
definition computer1
  where "computer1= 2"
definition computer2
  where "computer2= 3"
definition computer3
  where "computer3= 4"

definition example_network where
"example_network = {
  Above computer1 router1, Above  computer2 router1,
  Above computer2 router1, Above  computer3 router2}"

lemma "Joinable computer1 computer2 \<in> connection example_network"
  apply (unfold example_network_def)
  apply (rule_tac b=router1 in con_join)
   apply (rule con_in, blast) +
  done

subsection "Questions 1 (b)-(j)"

(* 1-b *)
lemma connection_monotonic:
  assumes "\<phi> \<in> connection A"
  shows   "\<phi> \<in> connection(A \<union> B)"
  using assms
  apply (induct)
  by (simp_all add:connection.intros)

(* 1-c *)
lemma connection_monotonic_simp:
  "connection A \<subseteq> connection (A \<union> B)"
  using connection_monotonic
  by blast

lemma connection_idem:
  shows "connection(connection A) = connection A"
  apply safe
   apply (erule connection.induct)
  by (auto intro:connection.intros)

(* 1-d *)
lemma connection_decompose:
  assumes "\<phi> \<in> connection(A \<union> B)"
  shows   "\<exists>C D. C \<subseteq> connection A \<and>
                 D \<subseteq> connection B \<and>
                 \<phi> \<in> connection(C \<union> D)"
  using assms
  using connection_monotonic_simp connection_idem
  by (meson connection.con_in subsetI)

(* 1-e *)
lemma connection_nil:
  assumes "\<phi> \<in> connection {}"
  shows "is_refl \<phi>"
  apply (rule connection.induct)
        apply (simp_all)
  using assms by blast+

(* 1-f *)
lemma join_refl: "Joinable a a \<in> connection A"
  apply (rule_tac b="a" in con_join)
  by (rule con_refl)+

lemma con_is_refl:
  assumes "is_refl \<phi>"
  shows "\<phi> \<in> connection A"
  using assms
  apply (unfold is_refl_def)
  apply induct
   apply simp_all
   apply (rule con_refl)
  apply (rule join_refl)
  done

(* 1-g *)
lemma connection_filter_refl:
  assumes "\<phi> \<in> connection A"
  shows "\<phi> \<in> connection(A - {\<phi>. is_refl \<phi>})"
  using assms
  using con_is_refl
  apply induct
  apply (simp_all add:connection.intros)
  by (metis DiffI connection.con_in mem_Collect_eq)

(* 1-h *)

lemma not_refl_wont_derive_no_reason:
  "\<lbrakk>a \<noteq> b; Above a b \<notin> A; Above a c \<in> A \<and> Above c b \<in> A \<rbrakk> \<Longrightarrow> Above a b \<in> connection A"
  using connection.con_in connection.con_trans
  by blast

lemma no_above_from_join_lemma:
  assumes "Above a b \<in> connection A"
  and "\<And>a b. Above a b \<notin> A"
shows "a = b"
  using assms
  apply -
  apply (induct "Above a b" arbitrary: a b rule:connection.inducts)
  by simp+

(* 1-i *)
lemma connection_compose:
  assumes "\<phi> \<in> connection(C \<union> D)"
  and     "C \<subseteq> connection A"
  and     "D \<subseteq> connection B"
  shows   "\<phi> \<in> connection(A \<union> B)"
  using connection_decompose
  proof -
  have f1: "\<forall>C Ca. (C::condition set) \<union> Ca = Ca \<or> Ca \<union> C \<noteq> Ca"
    by blast
    have f2: "\<forall>C Ca. (Ca::condition set) \<union> (C \<union> C) = Ca \<union> C"
      by blast
    have f3: "D \<union> connection B = connection B"
      using assms(3) by blast
    have f4: "\<forall>Ca. \<phi> \<in> connection Ca \<or> Ca \<union> (C \<union> D) \<noteq> Ca"
  using f1 by (metis assms(1) connection_monotonic)
    have f5: "C \<union> connection A = connection A"
  using assms(2) by blast
    have "\<forall>C. D \<union> connection C = connection C \<or> C \<union> B \<noteq> C"
      using f3 f1 by (metis connection_monotonic_simp le_iff_sup sup_assoc)
    then have "C \<union> (D \<union> connection (A \<union> B)) = connection (A \<union> B)"
      using f5 f2 by (metis (no_types) connection_monotonic_simp le_iff_sup sup_assoc)
    then show ?thesis
      using f4 by (metis (no_types) connection_idem le_iff_sup sup.order_iff sup_assoc)
  qed

(* 1-j *)
lemma connection_union_simp:
  "connection (connection A \<union> connection B) = connection (A \<union> B)"
  using connection_compose
  apply safe
   apply blast
  by (smt connection_decompose connection_idem)

lemma connection_compositional:
  assumes "connection A = connection B"
  shows   "connection(A \<union> C) = connection(B \<union> C)"
  using assms
  using connection_compose
  by (metis connection_union_simp)

section "Part 2"

datatype process =
  Cond condition
  | Par process process
  | Input nat process
  | Output nat process
  | Nil

datatype action =
  LInput nat | LOutput nat | LTau

primrec frame :: "process \<Rightarrow> condition set" where
  "frame Nil = {}"
| "frame(Cond \<phi>) = {\<phi>}"
| "frame(Par P Q) = frame P \<union> frame Q"
| "frame(Input \<phi> P) = {}"
| "frame(Output \<phi> P) = {}"

inductive semantics :: "condition set \<Rightarrow> process \<Rightarrow> action \<Rightarrow> process \<Rightarrow> bool"
  where
  semantics_input:
     "semantics A (Input n P) (LInput n) P"
| semantics_output:
    "semantics A (Output n P) (LOutput n) P"
| semantics_par_l:
    "semantics (A \<union> frame Q) P \<alpha> P'
     \<Longrightarrow> semantics A (Par P Q) \<alpha> (Par P' Q)"
| semantics_par_r:
    "semantics (A \<union> frame P) Q \<alpha> Q'
     \<Longrightarrow> semantics A (Par P Q) \<alpha> (Par P Q')"
| semantics_com_l:
    "\<lbrakk>semantics (A \<union> frame Q) P (LOutput n) P';
      semantics (A \<union> frame P) Q (LInput m) Q';
      Joinable n m \<in> connection(A \<union> frame P \<union> frame Q)\<rbrakk>
     \<Longrightarrow> semantics A (Par P Q) LTau (Par P' Q')"
| semantics_com_r:
    "\<lbrakk>semantics (A \<union> frame Q) P (LInput n) P';
      semantics (A \<union> frame P) Q (LOutput m) Q';
      Joinable n m \<in> connection(A \<union> frame P \<union> frame Q)\<rbrakk>
     \<Longrightarrow> semantics A (Par P Q) LTau (Par P' Q')"

thm semantics.cases

inductive_cases
  par: "semantics A (Par P Q) x R" and
  nil: "semantics A Nil x R" and
  cond: "semantics A (Cond cond) x R"
print_theorems
thm par

subsection "Questions 2 (a)-(c)"

(* 2-a *)
lemma semantics_monotonic:
  assumes "semantics A P \<alpha> Q"
  shows "semantics (A \<union> B) P \<alpha> Q"
  using assms connection_monotonic
  apply induct
      apply (simp_all add:semantics.intros)
     apply (metis semantics_par_l sup_assoc sup_commute)
    apply (simp add: Un_left_commute semantics_par_r sup.commute)
   apply (simp add: semantics_par_l sup_assoc)
  apply (smt inf_sup_aci(5) semantics_com_l subset_iff sup.assoc)
  by (smt inf_sup_aci(5) semantics_com_r sup.assoc)
thm semantics_monotonic[OF semantics_par_l]

(* 2-b *)
lemma semantics_monotonic_par_l:
  "semantics (A \<union> frame Q) P \<alpha> P' \<Longrightarrow> semantics (A \<union> B) (Par P Q) \<alpha> (Par P' Q)"
  by (frule semantics_monotonic[OF semantics_par_l])

lemma semantics_monotonic_par_r:
  "semantics (A \<union> frame P) Q \<alpha> Q' \<Longrightarrow> semantics (A \<union> B) (Par P Q) \<alpha> (Par P Q')"
  by (frule semantics_monotonic[OF semantics_par_r])

lemma semantics_empty_env:
  assumes "semantics A P \<alpha> Q"
  shows "\<exists>\<beta> Q'. semantics {} P \<beta> Q'"
  using assms
  apply (induct,simp_all add:semantics.intros)
  using semantics_input apply blast
  using semantics_output apply blast
  using semantics_monotonic semantics_par_l apply blast
  using semantics_monotonic semantics_par_r apply blast
  using semantics_monotonic semantics_par_r apply blast
  by (meson semantics_monotonic semantics_par_r)

(* 2-c *)
lemma semantics_swap_frame_with_con:
  assumes "semantics A P \<alpha> Q"
  and "B = connection A"
  shows "semantics B P \<alpha> Q"
  using assms
  by (metis connection.con_in le_iff_sup semantics_monotonic subsetI)

lemma semantics_mono_gen:
  "semantics A P \<alpha> Q \<Longrightarrow> A \<subseteq> B \<Longrightarrow> semantics B P \<alpha> Q"
  using semantics_monotonic
  by (metis sup.order_iff sup_commute)
lemma connection_mono_gen:
  "A \<subseteq> connection A"
  by (simp add: connection.con_in subsetI)

lemma connection_mono_gen2:
  "A \<subseteq> connection B \<Longrightarrow> connection A \<subseteq> connection B"
  by (metis connection_idem connection_monotonic_simp le_iff_sup)

lemma semantics_frame_simple:
  "semantics {} P \<alpha> R \<Longrightarrow> semantics (frame P) P \<alpha> R"
  using semantics_mono_gen by blast

lemma semantics_simple_par:
  "semantics A P \<alpha> Q  \<Longrightarrow> semantics (A \<union> frame P \<union> frame Q) P \<alpha> Q "
  by (simp add: semantics_monotonic)

thm semantics.inducts
lemma semantics_mono_con_gen:
  "semantics A P \<alpha> Q \<Longrightarrow> A \<subseteq> connection B \<Longrightarrow> semantics B P \<alpha> Q"
  apply (induct A P \<alpha> Q arbitrary: B rule:semantics.inducts)
       apply (auto intro:semantics.intros )
     apply (meson connection_mono_gen connection_monotonic_simp
      inf_sup_ord(4) semantics_par_l subset_trans)
    apply (meson Un_upper2 connection_mono_gen
      connection_monotonic_simp dual_order.trans semantics_par_r)
   apply (smt connection_compose connection_mono_gen
      connection_monotonic_simp le_sup_iff semantics_com_l subset_trans)
  by (smt connection_compose connection_mono_gen
      connection_monotonic_simp le_sup_iff semantics_com_r subset_trans)

section "Part 3"

definition stuck :: "process \<Rightarrow> bool"
where
  "stuck P \<equiv> \<forall>\<alpha> P'. semantics {} P \<alpha> P' \<longrightarrow> False"

primrec list_trans :: "_" where
  "list_trans A P [] Q = (P = Q)"
| "list_trans A P (\<alpha>#tr) Q =
    (\<exists>R. semantics A P \<alpha> R \<and> list_trans A R tr Q)"

definition traces_of :: "process \<Rightarrow> action list set"
  where "traces_of P = {tr | tr. \<exists>Q. list_trans {} P tr Q \<and> stuck Q}"

definition trace_eq :: "process \<Rightarrow> process \<Rightarrow> bool"
  where "trace_eq P Q = (traces_of P = traces_of Q)"

lemmas par_simp = semantics.simps[where ?a2.0="Par P Q" for P Q,simplified]

(*Some general lemma *)
lemma par_connection:
 "connection (A \<union> frame P \<union> frame Q) = connection (A \<union> frame (Par P Q))" by (simp add: sup_assoc)

lemma par_connection_swap:
 "connection (A \<union> frame (Par Q P)) = connection (A \<union> frame (Par P Q))"

  by (simp add: sup_commute)

lemma par_connection_assoc:
"connection (A \<union> frame (Par (Par P Q) R)) = connection (A \<union> frame (Par P (Par Q R)))"
  by (metis connection_union_simp par_connection)

subsection "Question 3 (a)"

lemma trace_eq_refl:
  shows "trace_eq P P"
  by (simp add: trace_eq_def)

lemma trace_eq_sym:
  assumes "trace_eq P Q"
    shows "trace_eq Q P"
  using assms trace_eq_def by auto

lemma trace_eq_trans:
  assumes "trace_eq P Q"
      and "trace_eq Q R"
    shows "trace_eq P R"
  using assms
  by (simp add:trace_eq_def)

subsection "Question 3 (b)"

lemma trace_eq_stuck:
  assumes "stuck P"
      and "stuck Q"
    shows "trace_eq P Q"
  using assms
  apply (unfold trace_eq_def traces_of_def)
  apply (unfold stuck_def)
  apply safe
  apply (metis list.exhaust list_trans.simps(1) list_trans.simps(2))
  by (metis list.exhaust list_trans.simps(1) list_trans.simps(2))

subsection "Question 3 (c)"
lemma trace_stuck_is_nil:
  "stuck P \<Longrightarrow> trace_eq P Nil"
  apply (unfold trace_eq_def stuck_def traces_of_def)
  apply safe
  apply (metis list_trans.simps(1) list_trans.simps(2) neq_Nil_conv nil)
  by (metis list.exhaust list_trans.simps(1) list_trans.simps(2) nil)

lemma stuck_is_stuck:
  "stuck P \<Longrightarrow> list_trans {} P [] P \<and> stuck P"
  by auto

lemma stuck_is_empty_list:
  "stuck P \<Longrightarrow> traces_of P = {[]}"
  apply (unfold traces_of_def)
  apply auto
  by (metis list.exhaust list_trans.simps(2) stuck_def)

lemma "\<forall>p. \<not> stuck p \<or> traces_of p = {[]}"
  using stuck_is_empty_list traces_of_def by auto

lemma semantics_par_stuck:
  "semantics A P \<alpha> P' \<Longrightarrow> stuck Q \<Longrightarrow> semantics A (Par P Q) \<alpha> (Par P' Q)"
  by (simp add: semantics_monotonic semantics_par_l)

lemma semantics_par_mono:
  "semantics A P \<alpha> P'\<Longrightarrow> semantics A (Par P Q) \<alpha> (Par P' Q)"
  by (simp add: semantics_monotonic semantics_par_l)

lemma par_stuck_stuck_is_stuck:
  "\<lbrakk>stuck P; stuck Q\<rbrakk> \<Longrightarrow> stuck (Par P Q)"
  proof -
    assume a1: "stuck P"
    assume a2: "stuck Q"
    obtain aa :: "process \<Rightarrow> action" and pp :: "process \<Rightarrow> process" where
      f3: "\<forall>p. (stuck p \<or> semantics {} p (aa p) (pp p)) \<and> ((\<forall>a pa. \<not> semantics {} p a pa) \<or> \<not> stuck p)"
  using stuck_def by moura
    obtain aaa :: "process \<Rightarrow> action" and ppa :: "process \<Rightarrow> process" where
      f4: "\<forall>C p a pa. semantics {} p (aaa p) (ppa p) \<or> \<not> semantics C p a pa"
      using semantics_empty_env by moura
    then have f5: "\<forall>p C a. \<not> semantics C Q a p"
      using f3 a2 by blast
    have "\<forall>p C a. \<not> semantics C P a p"
      using f4 f3 a1 by blast
  then have "\<not> semantics {} (Par P Q) (aa (Par P Q)) (pp (Par P Q))"
    using f5 par_simp by presburger
  then show ?thesis
    using f3 by blast
  qed

lemma semantics_par_stuck_to_stuck:
  "semantics A P \<alpha> P'\<Longrightarrow>stuck P' \<Longrightarrow> stuck Q
  \<Longrightarrow> stuck (Par P' Q) \<and> semantics A (Par P Q) \<alpha> (Par P' Q)"
  apply (rule conjI)
   apply (erule par_stuck_stuck_is_stuck, assumption)
  by (erule semantics_par_mono)

lemma list_trans_stuck_one:
  "list_trans A P \<alpha> P' \<Longrightarrow> stuck Q \<Longrightarrow>list_trans A (Par P Q) \<alpha> (Par P' Q)"
  apply (induct \<alpha> arbitrary:A P P' Q )
  apply (force)
  apply (clarsimp)
  apply (rule_tac x="Par R Q" in exI)
  apply (rule conjI)
   apply (simp add: semantics_par_stuck)
  by auto

lemma traces_of_monotonic:
  assumes "stuck R"
  shows "traces_of P \<subseteq> traces_of (Par P R)"
  using assms
  unfolding traces_of_def  stuck_def
  apply clarsimp
  apply (rule_tac x="Par Q R" in  exI)
  thm semantics_par_stuck
  apply (rule conjI)
   apply (rule list_trans_stuck_one)
    apply assumption +
   apply (unfold stuck_def, force)
  using par_stuck_stuck_is_stuck stuck_def by auto

\<comment> \<open>Some 3-d helper lemma\<close>

lemma cond_stuck:
  "p = Cond \<phi> \<Longrightarrow> stuck p"
  apply (unfold stuck_def)
  using cond by blast

lemma sub_stuck_par_stuck:
  "stuck (Par Q R) \<Longrightarrow> stuck Q \<and> stuck R"
  unfolding stuck_def
  apply (rule conjI)
  using semantics_par_mono apply blast
  using semantics_mono_con_gen semantics_par_r by blast

lemma sub_stuck_par_stuck2:
  " stuck Q \<and> stuck R \<Longrightarrow> stuck (Par Q R)"
  by (simp add: par_stuck_stuck_is_stuck)

lemma input_is_not_stuck:
  "stuck (Input n P) \<Longrightarrow> false"
  using semantics_input stuck_def by blast

lemma output_is_not_stuck:
  "stuck (Output n P) \<Longrightarrow> false"
  using semantics_output stuck_def by blast

lemma nil_stuck:
  "stuck Nil"
  using nil stuck_def by auto

lemma par_either:
  "semantics (A \<union> frame Q) P \<alpha> P' \<or> semantics (A \<union> frame P) Q \<alpha> Q'
   \<Longrightarrow> \<exists>P' Q'. semantics A (Par P Q) \<alpha> (Par P' Q')"
  using semantics_par_l semantics_par_r by blast

subsection "Question 3 (d)"

text \<open>Feel free to give this answer in free-text comments,
      or as Isabelle definitions. \<close>

\<comment> \<open>the basic situation, the x is in traces of (Par P Q) while not in traces of  P\<close>

definition proc1 where "proc1=Par (Input 0 Nil) (Output 1 Nil)"
definition proc2 where "proc2=Cond (Joinable 0 1)"

lemma proc2_stuck : "stuck proc2"
  using cond_stuck proc2_def by blast

lemma joinable_not_in_proc1: "Joinable 0 1 \<notin> connection (frame proc1)"
  by (metis connection_compositional connection_idem
      connection_mono_gen connection_nil frame.simps(3)
      frame.simps(4) frame.simps(5) is_refl.simps(2)
      proc1_def sup.order_iff zero_neq_one)

lemma joinable_in_par_both:
  "Joinable 0 1 \<in> connection ({} \<union> frame proc1 \<union> frame proc2)"
  unfolding proc1_def proc2_def
  using connection.con_in by auto

lemma proc_input_is_0:
  "semantics {} (Input 0 process.Nil) (LInput n) process.Nil = (n = 0)"
  apply safe
   apply (induct "({}:: condition set)" "(Input 0 process.Nil)" "(LInput n)"
          "process.Nil" rule:semantics.inducts)
   apply auto
  by (rule semantics_input)

lemma proc_output_is_1:
  "semantics {} (Output 1 process.Nil) (LOutput n) process.Nil = (n = 1)"
  apply safe
   apply (induct "({}:: condition set)" "(Output 1 process.Nil)" "(LOutput n)"
          "process.Nil" rule:semantics.inducts)
   apply auto
  by (rule semantics_output)

lemma proc_input_by_output_false:
  "semantics {} (Input 0 process.Nil) (LOutput n) process.Nil \<Longrightarrow> false"
  by (induct "({}:: condition set)" "(Input 0 process.Nil)" "(LOutput n)"
          "process.Nil" rule:semantics.inducts)

lemma ltau_not_in_proc1:
  "\<not> semantics {} proc1 LTau (Par Nil Nil)"
  unfolding proc1_def
  apply safe
  apply (induct rule:semantics.cases)
       apply (simp_all add:semantics.intros)
   apply clarsimp
   apply (erule proc_input_by_output_false)
  by (metis One_nat_def frame.simps(3) frame.simps(4) frame.simps(5)
      joinable_not_in_proc1 proc1_def proc_input_is_0 proc_output_is_1)

lemma ltau_not_in_proc1_gen:
  "\<not> semantics {} proc1 LTau P"
  apply safe
  apply (induct "{}::condition set" "proc1" LTau P arbitrary:P rule:semantics.induct)
  unfolding proc1_def
     apply (simp_all add:semantics.intros)
     apply clarsimp
     apply (erule semantics.cases; simp)+
  apply clarsimp
  using connection_nil is_refl.simps(2) by blast

lemma ltau_in_par_both:
  "Q=(Par (Par Nil Nil) proc2)
   \<Longrightarrow>stuck Q \<and> semantics {} (Par proc1 proc2) LTau (Par (Par Nil Nil) proc2)"
  apply safe
  apply (simp add: nil_stuck par_stuck_stuck_is_stuck proc2_stuck)
  apply (rule semantics_par_l)
  apply (unfold proc1_def proc2_def)
  apply (rule_tac n=0 and m=1 in semantics_com_r)
    apply (rule semantics_input)
   apply (rule semantics_output)
  apply (auto intro:connection.intros)
  done

lemma frame_from_stuck_action:
  "stuck R \<Longrightarrow> semantics (A \<union> frame R) P \<alpha> P' \<Longrightarrow>
    semantics A (Par P R) \<alpha> (Par P' R)"
  by (auto intro:semantics.intros)

\<comment> \<open>The LTau must in traces of (par proc1 proc2) while not in proc2\<close>

lemma ltau_in_traces_both:
  "[LTau] \<in> traces_of (Par proc1 proc2)"
  unfolding traces_of_def
  using ltau_in_par_both proc1_def proc2_def by auto

lemma ltau_not_in_trace_proc1:
  "[LTau] \<notin> traces_of proc1"
  unfolding traces_of_def proc1_def proc2_def
  apply clarsimp
  by (metis One_nat_def ltau_not_in_proc1_gen proc1_def)

\<comment> \<open>The reconstruced version of the 3-d is\<close>
lemma traces_of_not_antimonotonic_example:
  "stuck proc2 \<Longrightarrow> traces_of (Par proc1 proc2) \<subseteq> traces_of proc1 \<Longrightarrow> false"
  using ltau_in_traces_both ltau_not_in_trace_proc1 by blast

subsection "Question 3 (e)"
lemma traces_of_not_antimonotonic:
  assumes "\<And>P R. stuck R \<Longrightarrow> traces_of (Par P R) \<subseteq> traces_of P"
  shows "False"
  using assms
  using proc2_stuck traces_of_not_antimonotonic_example by auto

subsection "Question 3 (f)"
lemma semantics_par_assoc0:
  assumes "semantics A (Par P Q) \<alpha> R"
  shows "\<exists>P' Q' .
           R = Par P' Q' \<and>
           semantics A (Par P Q) \<alpha> (Par P' Q')"
  using assms
  unfolding stuck_def traces_of_def
  using par_simp by auto

lemma semantics_par_par_l_ltau:
  "semantics (A \<union> frame P \<union> frame S) Q (LOutput n) Q' \<Longrightarrow>
   semantics (A \<union> frame P \<union> frame Q) S (LInput m) S' \<Longrightarrow>
   Joinable n m \<in> connection (A \<union> frame P \<union> frame Q \<union> frame S)
  \<Longrightarrow> semantics A (Par (Par P Q) S) LTau (Par (Par P Q') S')"
  apply (simp add: semantics.simps[where ?a2.0="(Par (Par P Q) S)"])
  by (smt Un_commute semantics_par_r sup_assoc)

lemma semantics_par_par_r_ltau:
  "semantics (A \<union> frame P \<union> frame S) Q (LInput n) P' \<Longrightarrow>
  semantics (A \<union> frame P \<union> frame Q) S (LOutput m) Q'a \<Longrightarrow>
  Joinable n m \<in> connection (A \<union> frame P \<union> frame Q \<union> frame S)
     \<Longrightarrow> semantics A (Par (Par P Q) S) LTau (Par (Par P P') Q'a)"
  apply (simp add: semantics.simps[where ?a2.0="(Par (Par P Q) S)"])
  by (smt Un_commute semantics_par_r sup_assoc)

lemma semantics_com_par_par_l_ltau:
  "semantics (A \<union> (frame Q \<union> frame S)) P (LOutput n) P' \<Longrightarrow>
   semantics (A \<union> frame P) (Par Q S) (LInput m) Q' \<Longrightarrow>
   Joinable n m \<in> connection (A \<union> frame P \<union> (frame Q \<union> frame S))
    \<Longrightarrow> \<exists>Q'a S'. Q' = Par Q'a S' \<and>
      semantics A (Par (Par P Q) S) LTau (Par (Par P' Q'a) S')"
  apply (subst (asm) par_simp)
  apply clarsimp
  apply safe
   apply (smt semantics_com_l semantics_par_l sup_assoc sup_commute)
  by (smt frame.simps(3) semantics_com_l semantics_par_l sup.commute sup.left_commute)

lemma semantics_com_par_par_r_ltau:
  "semantics (A \<union> (frame Q \<union> frame S)) P (LInput n) P' \<Longrightarrow>
   semantics (A \<union> frame P) (Par Q S) (LOutput m) Q' \<Longrightarrow>
   Joinable n m \<in> connection (A \<union> frame P \<union> (frame Q \<union> frame S))
    \<Longrightarrow> \<exists>Q'a S'. Q' = Par Q'a S' \<and>
    semantics A (Par (Par P Q) S) LTau (Par (Par P' Q'a) S')"
  apply (subst (asm) par_simp)
  apply clarsimp
  apply safe
   apply (simp add: inf_sup_aci(5) inf_sup_aci(7) semantics.intros(6) semantics_par_l)
  by (smt frame.simps(3) semantics_com_r semantics_par_l sup_commute sup_left_commute)

lemma semantics_par_assoc1:
  assumes "semantics A (Par P (Par Q S)) \<alpha> R"
  shows "\<exists>P' Q' S'.
           R = Par P' (Par Q' S') \<and>
           semantics A (Par (Par P Q) S) \<alpha> (Par (Par P' Q') S')"
  using assms
  apply -
  apply (erule semantics.cases)
       apply (simp_all add:semantics.intros)
     apply clarsimp
     apply (simp add: inf_sup_aci(7) semantics_par_l sup.commute)
  apply (erule semantics.cases ;simp add:semantics.intros)
       apply (smt Un_left_commute inf_sup_aci(5) semantics_par_l semantics_par_r)
      apply (metis Un_assoc frame.simps(3) semantics_par_r)
     apply (simp add:semantics_par_par_l_ltau)
    apply (simp add: semantics_par_par_r_ltau)
   apply clarsimp
   apply (simp add: semantics_com_par_par_l_ltau)
  apply clarsimp
  apply (simp add: semantics_com_par_par_r_ltau)
  done

text \<open>
  This similar lemma will be needed later.
  You may use it without proof. \<close>
lemma semantics_par_assoc2:
  "semantics A (Par (Par P Q) S) \<alpha> R \<Longrightarrow>
  \<exists> P' Q' S'. R = Par (Par P' Q') S' \<and> semantics A (Par P (Par Q S)) \<alpha> (Par P' (Par Q' S'))"
  apply (erule semantics.cases)
       apply (simp_all add:semantics.intros)
     apply clarsimp
     apply (subst (asm) par_simp)
     apply (smt Un_commute frame.simps(3) semantics.intros(6)
        semantics_com_l semantics_par_l semantics_par_r sup_assoc)
    apply (metis frame.simps(3) semantics_par_r sup_assoc)
   apply clarsimp
  apply (subst (asm) par_simp, clarsimp)
  apply (smt frame.simps(3) inf_sup_aci(6) semantics_com_l semantics_par_r sup.commute)
  apply clarsimp
  apply (subst (asm) par_simp, clarsimp)
  apply safe
   apply (smt Un_assoc frame.simps(3) inf_sup_aci(5) semantics.intros(6) semantics_par_r)
  by (smt semantics.intros(6) semantics_par_r sup.assoc sup.commute)

subsection "Question 3 (g)"
lemma list_trans_par_assoc:
  "list_trans A (Par (Par P Q) S) tr (Par (Par P' Q') S') =
       list_trans A (Par P (Par Q S)) tr (Par P' (Par Q' S'))"
  apply (unfold list_trans_def)
  apply (rule iffI)
   apply (induct arbitrary: A P Q S P' Q' S' rule:list.induct; simp)
   apply (metis (no_types, lifting) semantics_par_assoc2)
  apply (induct arbitrary: A P Q S P' Q' S' rule:list.induct; simp)
  by (metis (no_types, lifting) semantics_par_assoc1)

subsection "Question 3 (h)"
lemma stuck_par:
  "stuck(Par P Q) = (stuck P \<and> stuck Q)"
  apply safe
  using semantics_monotonic semantics_par_l stuck_def apply fastforce
  using semantics_monotonic semantics_par_r stuck_def apply fastforce
  by (smt Collect_mono_iff list_trans.simps(1) stuck_def traces_of_def
      traces_of_monotonic)

subsection "Question 3 (i)"
lemma stuck_assoc:
  "stuck (Par (Par P Q) S) = stuck (Par P (Par Q S))"
  using stuck_par by presburger

lemma semantics_par_must_par_in_post:
  "semantics A (Par P Q) \<alpha> S \<Longrightarrow> \<exists> P' Q'. semantics A (Par P Q) \<alpha> (Par P' Q')"
  apply (frule semantics.cases)
  by (auto intro:semantics.intros)

lemma semantics_par_par_must_par_par_in_post1:
  "semantics A (Par P (Par Q R)) \<alpha> S
    \<Longrightarrow> \<exists> P' Q' R'. semantics A (Par P (Par Q R)) \<alpha> (Par P' (Par Q' R'))"
  using semantics_par_assoc1 by blast

lemma semantics_par_par_must_par_par_in_post2:
  "semantics A (Par (Par P Q) R) \<alpha> S
    \<Longrightarrow> \<exists> P' Q' R'. semantics A (Par (Par P Q) R) \<alpha> (Par (Par P' Q') R')"
  using semantics_par_assoc2 by blast

lemma semantics_par_assoc1_gen:
  "semantics A (Par (Par P Q) R) x S
     \<Longrightarrow> \<exists>S'. semantics A (Par P (Par Q R)) x S'"
  apply (drule semantics_par_par_must_par_par_in_post2)
  apply (erule exE)+
  apply (rule_tac x="(Par  P'(Par Q' R'))" in exI)
  using semantics_par_assoc2 by force

lemma semantics_par_assoc2_gen:
  "semantics A (Par P (Par Q R)) x S
     \<Longrightarrow> \<exists>S'. semantics A (Par (Par P Q) R) x S'"
  using semantics_par_assoc1 by blast

lemma semantics_par_assoc1_stuck_gen:
  "semantics A (Par (Par P Q) R) x S \<Longrightarrow> stuck S
     \<Longrightarrow> \<exists>S'. semantics A (Par P (Par Q R)) x S' \<and> stuck S'"
  using semantics_par_assoc2 stuck_assoc by blast

lemma semantics_par_assoc2_stuck_gen:
  "semantics A (Par P (Par Q R)) x S \<Longrightarrow> stuck S
     \<Longrightarrow> \<exists>S'. semantics A (Par (Par P Q) R) x S' \<and> stuck S'"
  using semantics_par_assoc1 stuck_assoc by blast

lemma list_trace_par_par_post1:
  "list_trans A (Par (Par P Q) R) x S
     \<Longrightarrow> \<exists>P' Q' R'. S = (Par (Par P' Q') R')"
  unfolding list_trans_def
  apply (induct arbitrary: A P Q R S rule:list.inducts,force)
  by (smt list.simps(7) semantics_par_assoc2)

lemma list_trace_par_par_post2:
  "list_trans A (Par  P (Par Q R)) x S
     \<Longrightarrow> \<exists>P' Q' R'. S = (Par  P' (Par Q' R'))"
  unfolding list_trans_def
  apply (induct arbitrary: A P Q R S rule:list.inducts,force)
  by (smt list.simps(7) semantics_par_assoc1)

lemma list_trans_par_assoc_gen1:
  "list_trans A (Par (Par P Q) R) tr S \<Longrightarrow>
    \<exists> S'. list_trans A (Par P (Par Q R)) tr S'"
  using list_trace_par_par_post1 list_trans_par_assoc by blast

lemma list_trans_par_assoc_gen2:
  "list_trans A (Par P (Par Q R)) tr S \<Longrightarrow>
    \<exists> S'. list_trans A (Par (Par P Q) R) tr S'"
  using list_trace_par_par_post2 list_trans_par_assoc by blast

lemma trace_eq_par_assoc:
  shows "trace_eq (Par (Par P Q) S) (Par P (Par Q S))"
  apply (unfold trace_eq_def traces_of_def )
  apply (rule equalityI)
   apply clarsimp
   using list_trace_par_par_post1 list_trans_par_assoc stuck_assoc apply blast
  apply clarsimp
  using list_trace_par_par_post2 list_trans_par_assoc stuck_assoc by blast

subsection "Question 3 (j)"
lemma par_nil_is_origin:
  "semantics A (Par P Nil) tr (Par P' Nil) \<Longrightarrow> semantics A P tr P'"
  using nil par_simp by auto

lemma par_nil_has_nil_in_post:
  "semantics A (Par P Nil) tr S \<Longrightarrow>\<exists> P'. S = (Par P' Nil) \<and> semantics A (Par P Nil) tr (Par P' Nil)"
  apply (subst (asm) par_simp)
  apply clarsimp
  apply safe
     apply (auto intro: semantics_par_mono nil)
  done

lemma par_nil_is_origin_gen:
  "semantics A (Par P Nil) tr S \<Longrightarrow>\<exists> S'.  semantics A P tr S'"
  apply (frule par_nil_has_nil_in_post)
  using par_nil_is_origin by blast

lemma list_trans_par_nil:
  "list_trans A (Par P Nil) tr (Par P' Nil) \<Longrightarrow> list_trans A P tr P'"
  apply (induct tr arbitrary:A P P', force)
  apply clarsimp
  apply (frule par_nil_has_nil_in_post)
  apply (erule exE)
  apply (rule_tac x="P'a" in exI)
  using par_nil_is_origin by blast

lemma list_trans_par_nil_has_nil_in_post:
  "list_trans A (Par P Nil) tr S
     \<Longrightarrow> \<exists> P'. S= (Par P' Nil) \<and> list_trans A (Par P Nil ) tr (Par P' Nil)"
  apply (induct tr arbitrary:A P P', force)
  using list_trans.simps(2) par_nil_has_nil_in_post by blast

lemma list_trans_par_nil_gen:
  "list_trans A (Par P Nil) tr S \<Longrightarrow> \<exists> S'. list_trans A P tr S'"
  apply (induct tr arbitrary: A P S)
  apply auto[1]
  using list_trans_par_nil_has_nil_in_post list_trans_par_nil by blast

lemma trace_eq_nil_par:
  shows "trace_eq P (Par P Nil)"
  apply (unfold trace_eq_def traces_of_def)
  apply (rule equalityI)
  apply clarsimp
  using list_trans_stuck_one nil_stuck par_stuck_stuck_is_stuck apply blast
  apply clarsimp
  using list_trans_par_nil_has_nil_in_post list_trans_par_nil sub_stuck_par_stuck
  by blast

subsection "Question 3 (k)"

lemma list_trans_par_has_par_in_post:
  "list_trans A (Par P Q) tr S
   \<Longrightarrow> \<exists> P' Q'. S=(Par P' Q') \<and> list_trans A (Par P Q) tr (Par P' Q')"
  apply (induct tr arbitrary: A P Q S, auto)
  by (metis semantics_par_assoc0)
\<comment> \<open>the old one is not strong enough\<close>
lemma semantics_par_assoc0_real:
  "semantics A (Par P Q) \<alpha> R \<Longrightarrow>
    \<exists> P' Q'. R=Par P' Q' \<and> semantics A (Par Q P) \<alpha> (Par Q' P')"
  apply (subst (asm) par_simp)
  apply safe
     apply (auto intro:semantics.intros)
   apply (smt connection.con_mirror semantics_com_r sup_assoc sup_commute)
  by (smt connection.con_mirror semantics_com_l sup_assoc sup_commute)

lemma list_trans_assoc:
  "list_trans A (Par P Q) tr S
     \<Longrightarrow> \<exists> P' Q'. S= (Par P' Q') \<and> list_trans A (Par Q P) tr (Par Q' P')"
  apply (induct tr arbitrary: A P Q S, auto)
  by (metis semantics_par_assoc0_real)

lemma trace_eq_par_comm:
  shows "trace_eq (Par P Q) (Par Q P)"
  apply (unfold trace_eq_def traces_of_def )
  apply safe
  by (metis list_trans_assoc stuck_par sub_stuck_par_stuck)+

end


theory Pls_comm_enat
  imports Main  "~~/src/HOL/Library/BNF_Corec" "$HIPSTER_HOME/IsaHipster"
begin

setup Tactic_Data.set_coinduct_sledgehammer

codatatype (sset: 'a) Stream =
  SCons (shd: 'a) (stl: "'a Stream")

codatatype ENat = is_zero: EZ | ESuc (epred: ENat)

primcorec eplus :: "ENat \<Rightarrow> ENat \<Rightarrow> ENat" where
"eplus m n = (if is_zero m then n else ESuc (eplus (epred m) n))"

primcorec pls :: "ENat Stream \<Rightarrow> ENat Stream \<Rightarrow> ENat Stream" where
  "pls s t = SCons (eplus (shd s) (shd t)) (pls (stl s) (stl t))"

datatype 'a Lst =
  Emp
  | Cons "'a" "'a Lst"

fun obsStream :: "int \<Rightarrow> 'a Stream \<Rightarrow> 'a Lst" where
"obsStream n s = (if (n \<le> 0) then Emp else Cons (shd s) (obsStream (n - 1) (stl s)))"

hipster_obs Stream Lst obsStream pls
lemma lemma_a [thy_expl]: "eplus x EZ = x"
  apply (coinduction  arbitrary: x rule: Pls_comm_enat.ENat.coinduct_strong)
  by simp

lemma lemma_aa [thy_expl]: "eplus EZ x = x"
apply (coinduction  arbitrary: x rule: Pls_comm_enat.ENat.coinduct_strong)
by simp

lemma lemma_ab [thy_expl]: "eplus (ESuc x) y = eplus x (ESuc y)"
apply (coinduction  arbitrary: x y rule: Pls_comm_enat.ENat.coinduct_strong)
apply simp
by (metis ENat.collapse(2) eplus.code)

lemma lemma_ac [thy_expl]: "ESuc (eplus x y) = eplus x (ESuc y)"
apply (coinduction  arbitrary: x y rule: Pls_comm_enat.ENat.coinduct_strong)
apply simp
by (metis eplus.code)

lemma lemma_ad [thy_expl]: "eplus (eplus x y) z = eplus x (eplus y z)"
apply (coinduction  arbitrary: x y z rule: Pls_comm_enat.ENat.coinduct_strong)
apply simp
by auto

lemma lemma_ae [thy_expl]: "eplus y x = eplus x y"
apply (coinduction  arbitrary: x y rule: Pls_comm_enat.ENat.coinduct_strong)
apply simp
by (metis ENat.collapse(1) ENat.collapse(2) lemma_a lemma_ab)

theorem pls_comm: "pls s t = pls t s"
  by hipster_coinduct_sledgehammer
  (*by hipster_coinduct_sledgehammer
Failed to apply initial proof method*)


(* Title: Quantales
   Author: Georg Struth
   Maintainer: Georg Struth <g.struth@sheffield.ac.uk>
   Contributions by Brijesh Dongol, Victor Gomes, Ian Hayes
*)

section \<open>Quantales\<close>

theory Quantales
  imports
    "Order_Lattice_Props.Closure_Operators"
   Kleene_Algebra.Dioid
begin

subsection \<open>Families of Proto-Quantales\<close>

text \<open>Proto-Quanales are complete lattices equipped with an operation of composition or multiplication
that need not be associative. The notation in this component differs from Rosenthal's \<^cite>\<open>"Rosenthal90"\<close>, but is consistent with the one we use
for semirings and Kleene algebras.\<close>

class proto_near_quantale = complete_lattice + times +
  assumes Sup_distr: "\<Squnion>X \<cdot> y = (\<Squnion>x \<in> X. x \<cdot> y)"

lemma Sup_pres_multr: "Sup_pres (\<lambda>(z::'a::proto_near_quantale). z \<cdot> y)"
  unfolding fun_eq_iff comp_def Sup_distr by simp

lemma sup_pres_multr: "sup_pres (\<lambda>(z::'a::proto_near_quantale). z \<cdot> y)"
  using Sup_pres_multr Sup_sup_pres by fastforce

lemma bot_pres_multr: "bot_pres (\<lambda>(z::'a::proto_near_quantale). z \<cdot> y)"
  by (metis SUP_empty Sup_distr Sup_empty)

context proto_near_quantale
begin

lemma mult_botl [simp]: "\<bottom> \<cdot> x = \<bottom>"
proof -
  have "\<bottom> \<cdot> x = (\<Squnion>a\<in>{}. a \<cdot> x)"
    using Sup_distr Sup_empty by blast
  thus ?thesis
    by simp
qed

lemma sup_distr: "(x \<squnion> y) \<cdot> z = (x \<cdot> z) \<squnion> (y \<cdot> z)"
  by (smt SUP_empty SUP_insert Sup_distr sup_Sup sup_bot.right_neutral)

lemma mult_isor: "x \<le> y \<Longrightarrow> x \<cdot> z \<le> y \<cdot> z"
  by (metis sup.absorb_iff1 sup_distr)

text \<open>Left and right residuals can be defined in every proto-nearquantale.\<close>

definition bres :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixr "\<rightarrow>" 60) where
  "x \<rightarrow> z = \<Squnion>{y. x \<cdot> y \<le> z}"

definition fres :: "'a \<Rightarrow> 'a \<Rightarrow> 'a" (infixl "\<leftarrow>" 60) where
  "z \<leftarrow> y = \<Squnion>{x. x \<cdot> y \<le> z}"

text \<open>The left one is a right adjoint  to composition. For the right one, additional assumptions are needed\<close>

lemma bres_galois_imp: "x \<cdot> y \<le> z \<Longrightarrow> y \<le> x \<rightarrow> z"
  by (simp add: Sup_upper bres_def)

lemma fres_galois: "(x \<cdot> y \<le> z) = (x \<le> z \<leftarrow> y)"
proof
  show "x \<cdot> y \<le> z \<Longrightarrow> x \<le> z \<leftarrow> y"
    by (simp add: Sup_upper fres_def)
next
  assume "x \<le> z \<leftarrow> y"
  hence "x \<cdot> y \<le> \<Squnion>{x. x \<cdot> y \<le> z} \<cdot> y"
    by (simp add: fres_def mult_isor)
  also have "... = \<Squnion>{x \<cdot> y |x. x \<cdot> y \<le> z}"
    by (simp add: Sup_distr setcompr_eq_image)
  also have "... \<le> z"
    by (rule Sup_least, auto)
  finally show "x \<cdot> y \<le> z" .
qed

end

lemma fres_adj: "(\<lambda>(x::'a::proto_near_quantale). x \<cdot> y) \<stileturn> (\<lambda>x. x \<leftarrow> y)"
  by (simp add: adj_def fres_galois)

context proto_near_quantale
begin

lemma fres_canc1: "(y \<leftarrow> x) \<cdot> x \<le> y"
  by (simp add: fres_galois)

lemma fres_canc2: "y \<le> (y \<cdot> x) \<leftarrow> x"
  using fres_galois by force

lemma inf_fres: "y \<cdot> x = \<Sqinter>{z. y \<le> z \<leftarrow> x}"
  by (metis (mono_tags, lifting) fres_canc2 Inf_eqI fres_galois mem_Collect_eq)

lemma bres_iso: "x \<le> y \<Longrightarrow> z \<rightarrow> x \<le> z \<rightarrow> y"
  using Sup_le_iff bres_def bres_galois_imp by force

lemma bres_anti: "x \<le> y \<Longrightarrow> y \<rightarrow> z \<le> x \<rightarrow> z"
  by (smt Sup_le_iff bres_def bres_galois_imp fres_galois order_trans mem_Collect_eq)

lemma fres_iso: "x \<le> y \<Longrightarrow> x \<leftarrow> z \<le> y \<leftarrow> z"
  using fres_galois dual_order.trans by blast

lemma bres_top_top [simp]: "\<top> \<rightarrow> \<top> = \<top>"
  by (simp add: bres_galois_imp dual_order.antisym)

lemma fres_top_top [simp]: "\<top> \<leftarrow> \<top> = \<top>"
  using fres_galois top_greatest top_le by blast

lemma bres_bot_bot [simp]: "\<bottom> \<rightarrow> \<bottom> = \<top>"
  by (simp add: bres_galois_imp top_le)

lemma left_sided_localp: "\<top> \<cdot> y = y \<Longrightarrow> x \<cdot> y \<le> y"
  by (metis mult_isor top_greatest)

lemma fres_sol: "((y \<leftarrow> x) \<cdot> x = y) = (\<exists>z. z \<cdot> x = y)"
  using dual_order.antisym fres_canc1 fres_canc2 mult_isor by fastforce

lemma sol_fres: "((y \<cdot> x) \<leftarrow> x = y) = (\<exists>z. y = z \<leftarrow> x)"
  by (metis fres_canc1 fres_canc2 fres_sol order.eq_iff fres_galois)

end

class proto_pre_quantale = proto_near_quantale +
  assumes Sup_subdistl: "(\<Squnion>y \<in> Y. x \<cdot> y) \<le> x \<cdot> \<Squnion>Y"

begin

lemma sup_subdistl: "(x \<cdot> y) \<squnion> (x \<cdot> z) \<le> x \<cdot> (y \<squnion> z)"
  by (smt SUP_empty SUP_insert Sup_subdistl sup_Sup sup_bot_right)

lemma mult_isol: "x \<le> y \<Longrightarrow> z \<cdot> x \<le> z \<cdot> y"
  by (metis le_iff_sup le_sup_iff sup_subdistl)

lemma fres_anti: "x \<le> y \<Longrightarrow> z \<leftarrow> y \<le> z \<leftarrow> x"
  using dual_order.trans fres_galois mult_isol by blast

end

class weak_proto_quantale = proto_near_quantale +
  assumes weak_Sup_distl: "Y \<noteq> {} \<Longrightarrow> x \<cdot> \<Squnion>Y = (\<Squnion>y \<in> Y. x \<cdot> y)"

begin

subclass proto_pre_quantale
proof unfold_locales
  have a: "\<And>x Y. Y = {} \<Longrightarrow> (\<Squnion>y \<in> Y. x \<cdot> y) \<le> x \<cdot> \<Squnion>Y"
    by simp
  have b: "\<And>x Y. Y \<noteq> {} \<Longrightarrow> (\<Squnion>y \<in> Y. x \<cdot> y) \<le> x \<cdot> \<Squnion>Y"
    by (simp add: weak_Sup_distl)
  show  "\<And>x Y. (\<Squnion>y \<in> Y. x \<cdot> y) \<le> x \<cdot> \<Squnion>Y"
    using a b by blast
qed

lemma  sup_distl: "x \<cdot> (y \<squnion> z) = (x \<cdot> y) \<squnion> (x \<cdot> z)"
  using weak_Sup_distl[where Y="{y, z}"] by (fastforce intro!: Sup_eqI)

lemma "y \<le> x \<rightarrow> z \<longrightarrow> x \<cdot> y \<le> z" (* nitpick [expect = genuine] *)
oops

end

class proto_quantale = proto_near_quantale +
  assumes Sup_distl: "x \<cdot> \<Squnion>Y = (\<Squnion>y \<in> Y. x \<cdot> y)"

lemma Sup_pres_multl: "Sup_pres (\<lambda>(z::'a::proto_quantale). x \<cdot> z)"
  unfolding fun_eq_iff comp_def Sup_distl by simp

lemma sup_pres_multl: "sup_pres (\<lambda>(z::'a::proto_quantale). x \<cdot> z)"
  by (metis (no_types, lifting) SUP_insert Sup_distl Sup_empty Sup_insert sup_bot_right)

lemma bot_pres_multl: "bot_pres (\<lambda>(z::'a::proto_quantale). x \<cdot> z)"
  by (metis SUP_empty Sup_distl Sup_empty)

context proto_quantale
begin

subclass weak_proto_quantale
  by standard (simp add: Sup_distl)

lemma mult_botr [simp]: "x \<cdot> \<bottom> = \<bottom>"
  by (smt image_empty Sup_distl Sup_empty)

text \<open>Now there is also an adjunction for the other residual.\<close>

lemma bres_galois: "x \<cdot> y \<le> z \<longleftrightarrow> y \<le> x \<rightarrow> z"
proof
  show "x \<cdot> y \<le> z \<Longrightarrow> y \<le> x \<rightarrow> z"
    by (simp add: Sup_upper bres_def)
next
  assume "y \<le> x \<rightarrow> z"
  hence "x \<cdot> y \<le> x \<cdot> \<Squnion>{y. x \<cdot> y \<le> z}"
    by (simp add: bres_def mult_isol)
  also have "... = \<Squnion>{x \<cdot> y |y. x \<cdot> y \<le> z}"
    by (simp add: Sup_distl setcompr_eq_image)
  also have "... \<le> z"
    by (rule Sup_least, safe)
  finally show "x \<cdot> y \<le> z" .
qed

end

lemma bres_adj: "(\<lambda>(y::'a::proto_quantale). x \<cdot> y) \<stileturn> (\<lambda>y. x \<rightarrow> y)"
  by (simp add: adj_def bres_galois)

context proto_quantale
begin

lemma bres_canc1: "x \<cdot> (x \<rightarrow> y) \<le> y"
  by (simp add: bres_galois)

lemma bres_canc2: "y \<le> x \<rightarrow> (x \<cdot> y)"
  by (simp add: bres_galois_imp)

lemma  inf_bres: "x \<cdot> y = \<Sqinter>{z. y \<le> x \<rightarrow> z}"
  using bres_galois fres_galois inf_fres by force

lemma bres_sol: "(x \<cdot> (x \<rightarrow> y) = y) = (\<exists>z. x \<cdot> z = y)"
  using bres_galois order.antisym mult_isol by force

lemma sol_bres: "(x \<rightarrow> (x \<cdot> y) = y) = (\<exists>z. y = x \<rightarrow> z)"
  by (metis bres_canc1 bres_canc2 bres_iso order.eq_iff)

end

lemma bres_fres_clop: "clop (\<lambda>x::'a::proto_quantale. y \<leftarrow> (x \<rightarrow> y))"
  unfolding clop_def comp_def mono_def le_fun_def
  by (metis bres_anti bres_canc1 bres_galois_imp fres_anti fres_galois id_apply)

lemma fres_bres_clop: "clop (\<lambda>x::'a::proto_quantale. (y \<leftarrow> x) \<rightarrow> y)"
  unfolding clop_def comp_def mono_def le_fun_def
  by (metis bres_anti bres_canc1 bres_galois_imp fres_anti fres_canc1 fres_galois id_apply)

subsection \<open>Families of Quantales\<close>

class near_quantale = proto_near_quantale + semigroup_mult

sublocale near_quantale \<subseteq> nsrnq: near_dioid "(\<squnion>)" "(\<cdot>)" "(\<le>)" "(<)"
  apply unfold_locales
       apply (simp add: sup_assoc)
      apply (simp add: sup_commute)
     apply (simp_all add: sup_distr)
   apply (simp add: le_iff_sup)
  by auto

context near_quantale
begin

lemma fres_curry: "(z \<leftarrow> y) \<leftarrow> x = z \<leftarrow> (x \<cdot> y)"
  by (metis order.eq_iff fres_canc1 fres_galois mult_assoc)

end

class unital_near_quantale = near_quantale + monoid_mult

sublocale unital_near_quantale \<subseteq> nsrnqo: near_dioid_one "(\<squnion>)" "(\<cdot>)" "1""(\<le>)" "(<)"
  by (unfold_locales, simp_all)

context unital_near_quantale
begin

definition iter :: "'a \<Rightarrow> 'a" where
  "iter x \<equiv> \<Sqinter>i. x ^ i"

lemma iter_ref [simp]: "iter x \<le> 1"
  by (metis iter_def Inf_lower power.power_0 rangeI)

lemma le_top: "x \<le> \<top> \<cdot> x"
  by (metis mult.left_neutral mult_isor top_greatest)

lemma top_times_top [simp]: "\<top> \<cdot> \<top> = \<top>"
  by (simp add: le_top top_le)

lemma bres_one: "1 \<le> x \<rightarrow> x"
  by (simp add: bres_galois_imp)

lemma fres_one: "1 \<le> x \<leftarrow> x"
  using fres_galois by fastforce

end

class pre_quantale = proto_pre_quantale + semigroup_mult

begin

subclass near_quantale ..

lemma fres_interchange: "z \<cdot> (x \<leftarrow> y) \<le> (z \<cdot> x) \<leftarrow> y"
  using Sup_upper fres_canc1 fres_def mult_isol mult_assoc by fastforce

end

sublocale pre_quantale \<subseteq>  psrpq: pre_dioid "(\<squnion>)" "(\<cdot>)" "(\<le>)" "(<)"
  by (unfold_locales, simp add: mult_isol)

class unital_pre_quantale = pre_quantale + monoid_mult

begin

subclass unital_near_quantale ..

text \<open>Abstract rules of Hoare logic without the star can be derived.\<close>

lemma h_w1: "x \<le> x' \<Longrightarrow>  x' \<cdot> y \<le> z \<Longrightarrow> x \<cdot> y \<le> z"
  by (simp add: fres_galois)

lemma h_w2: "x \<cdot> y \<le> z' \<Longrightarrow> z' \<le> z \<Longrightarrow> x \<cdot> y \<le> z"
  using order_trans by blast

lemma h_seq: "x \<cdot> v \<le> z \<Longrightarrow> y \<cdot> w \<le> v \<Longrightarrow> x \<cdot> y \<cdot> w \<le> z"
  using dual_order.trans mult_isol mult_assoc by presburger

lemma h_sup: "x \<cdot> w \<le> z \<Longrightarrow> y \<cdot> w \<le> z \<Longrightarrow> (x \<squnion> y) \<cdot> w \<le> z"
  by (simp add: fres_galois)

lemma h_Sup: "\<forall>x \<in> X. x \<cdot> w \<le> z \<Longrightarrow> \<Squnion>X \<cdot> w \<le> z"
  by (simp add: Sup_least fres_galois)

end

sublocale unital_pre_quantale \<subseteq>  psrpqo: pre_dioid_one "(\<squnion>)" "(\<cdot>)" "1" "(\<le>)" "(<)"..

class weak_quantale = weak_proto_quantale + semigroup_mult

begin

subclass pre_quantale ..

text \<open>The following counterexample shows an important consequence of weakness:
the absence of right annihilation.\<close>

lemma "x \<cdot> \<bottom> = \<bottom>" (*nitpick[expect=genuine]*)
  oops

end

class unital_weak_quantale = weak_quantale + monoid_mult

lemma (in unital_weak_quantale) "x \<cdot> \<bottom> = \<bottom>" (*nitpick[expect=genuine]*)
  oops

subclass (in unital_weak_quantale) unital_pre_quantale ..

sublocale unital_weak_quantale \<subseteq>  wswq: dioid_one_zerol "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "(\<le>)" "(<)"
  by (unfold_locales, simp_all add: sup_distl)

class quantale = proto_quantale + semigroup_mult

begin

subclass weak_quantale ..

lemma Inf_subdistl: "x \<cdot> \<Sqinter>Y \<le> (\<Sqinter>y \<in> Y. x \<cdot> y)"
  by (auto intro!: Inf_greatest Inf_lower mult_isol)

lemma Inf_subdistr: "\<Sqinter> X \<cdot> y \<le> (\<Sqinter>x \<in> X. x \<cdot> y)"
  by (auto intro!: Inf_greatest Inf_lower mult_isor)

lemma fres_bot_bot [simp]: "\<bottom> \<leftarrow> \<bottom> = \<top>"
  by (simp add: fres_def)

lemma bres_interchange: "(x \<rightarrow> y) \<cdot> z \<le> x \<rightarrow> (y \<cdot> z)"
  by (metis bres_canc1 bres_galois mult_isor mult_assoc)

lemma bres_curry: "x \<rightarrow> (y \<rightarrow> z) = (y \<cdot> x) \<rightarrow> z"
  by (metis bres_canc1 bres_galois dual_order.antisym mult_assoc)

lemma fres_bres: "x \<rightarrow> (y \<leftarrow> z) = (x \<rightarrow> y) \<leftarrow> z"
proof-
  {fix w
  have "(w \<le> x \<rightarrow> (y \<leftarrow> z)) = (x \<cdot> w \<le> y \<leftarrow> z)"
    by (simp add: bres_galois)
  also have "... = (x \<cdot> w \<cdot> z \<le> y)"
    by (simp add: fres_galois)
  also have "... = (w \<cdot> z \<le> x \<rightarrow> y)"
    by (simp add: bres_galois mult_assoc)
  also have "... = (w \<le> (x \<rightarrow> y) \<leftarrow> z)"
    by (simp add: fres_galois)
  finally have "(w \<le> x \<rightarrow> (y \<leftarrow> z)) = (w \<le> (x \<rightarrow> y) \<leftarrow> z)".}
  thus ?thesis
    using order.eq_iff by blast
qed

end

class quantale_with_dual = quantale + complete_lattice_with_dual

class unital_quantale = quantale + monoid_mult

class unital_quantale_with_dual = unital_quantale + quantale_with_dual

subclass (in unital_quantale) unital_weak_quantale ..

sublocale unital_quantale \<subseteq> wswq: dioid_one_zero "(\<squnion>)" "(\<cdot>)" "1" "\<bottom>" "(\<le>)" "(<)"
  by (unfold_locales, simp)

class ab_quantale = quantale + ab_semigroup_mult

begin

lemma bres_fres_eq: "x \<rightarrow> y = y \<leftarrow> x"
  by (simp add: fres_def bres_def mult_commute)

end

class ab_unital_quantale = ab_quantale + unital_quantale

sublocale complete_heyting_algebra \<subseteq> chaq: ab_unital_quantale "(\<sqinter>)" _ _ _ _ _ _ _ _ \<top>
  by (unfold_locales, simp add: inf.assoc, simp_all add: inf.assoc ch_dist inf.commute)

class distrib_quantale = quantale + distrib_lattice

class bool_quantale = quantale + complete_boolean_algebra_alt

class distrib_unital_quantale = unital_quantale + distrib_lattice

class bool_unital_quantale = unital_quantale + complete_boolean_algebra_alt

class distrib_ab_quantale = distrib_quantale + ab_quantale

class bool_ab_quantale = bool_quantale + ab_quantale

class distrib_ab_unital_quantale = distrib_quantale + unital_quantale

class bool_ab_unital_quantale = bool_ab_quantale + unital_quantale

sublocale complete_boolean_algebra \<subseteq> cba_quantale: bool_ab_unital_quantale inf _ _ _ _ _ _ _ _ _ _ \<top>
  by (unfold_locales, simp add: inf.assoc, simp_all add: inf.commute Setcompr_eq_image inf_Sup Sup_inf)

context complete_boolean_algebra
begin

text \<open>In this setting, residuation is classical implication.\<close>

lemma cba_bres1: "x \<sqinter> y \<le> z \<longleftrightarrow> x \<le> cba_quantale.bres y z"
  using cba_quantale.bres_galois inf.commute by fastforce

lemma cba_bres2: "x \<le> -y \<squnion> z \<longleftrightarrow> x \<le> cba_quantale.bres y z"
  using cba_bres1 shunt1 by auto

lemma cba_bres_prop: "cba_quantale.bres x y = -x \<squnion> y"
  using cba_bres2 order.eq_iff by blast

end

subsection \<open>Quantales Based on Sup-Lattices and Inf-Lattices\<close>

text \<open>These classes are defined for convenience in instantiation and interpretation proofs, or likewise.
They are useful, e.g., in the context of predicate transformers, where only one of Sup or Inf may be well behaved.\<close>

class Sup_quantale = Sup_lattice + semigroup_mult +
  assumes Supq_distr: "\<Squnion>X \<cdot> y = (\<Squnion>x \<in> X. x \<cdot> y)"
  and Supq_distl: "x \<cdot> \<Squnion>Y = (\<Squnion>y \<in> Y. x \<cdot> y)"

class unital_Sup_quantale = Sup_quantale + monoid_mult

class Inf_quantale = Inf_lattice + monoid_mult +
  assumes Supq_distr: "\<Sqinter>X \<cdot> y = (\<Sqinter>x \<in> X. x \<cdot> y)"
  and Supq_distl: "x \<cdot> \<Sqinter>Y = (\<Sqinter>y \<in> Y. x \<cdot> y)"

class unital_Inf_quantale = Inf_quantale + monoid_mult

sublocale Inf_quantale \<subseteq> qdual: Sup_quantale _ Inf "(\<ge>)"
  by (unfold_locales, simp_all add: Supq_distr Supq_distl)

sublocale unital_Inf_quantale \<subseteq> uqdual: unital_Sup_quantale _ _ Inf  "(\<ge>)"..

sublocale Sup_quantale \<subseteq> supq: quantale _ Infs Sup_class.Sup infs "(\<le>)" le sups bots tops
  by (unfold_locales, simp_all add: Supq_distr Supq_distl)

sublocale unital_Sup_quantale \<subseteq> usupq: unital_quantale _ _ Infs Sup_class.Sup infs "(\<le>)" le sups bots tops..

subsection \<open>Products of Quantales\<close>

definition "Inf_prod X = ((\<Sqinter>x \<in> X. fst x), (\<Sqinter>x \<in> X. snd x))"

definition "inf_prod x y = (fst x \<sqinter> fst y, snd x \<sqinter> snd y)"

definition "bot_prod = (bot,bot)"

definition "Sup_prod X = ((\<Squnion>x \<in> X. fst x), (\<Squnion>x \<in> X. snd x))"

definition "sup_prod x y = (fst x \<squnion> fst y, snd x \<squnion> snd y)"

definition "top_prod = (top,top)"

definition "less_eq_prod x y \<equiv> less_eq (fst x) (fst y) \<and> less_eq (snd x) (snd y)"

definition "less_prod x y \<equiv> less_eq (fst x) (fst y) \<and> less_eq (snd x) (snd y) \<and> x \<noteq> y"

definition "times_prod' x y = (fst x \<cdot> fst y, snd x \<cdot> snd y)"

definition "one_prod = (1,1)"

definition "dual_prod x = (\<partial> (fst x),\<partial> (snd x))"

interpretation prod: complete_lattice Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::complete_lattice \<times> 'b::complete_lattice)"
  by standard (auto simp add: Inf_prod_def Sup_prod_def inf_prod_def sup_prod_def bot_prod_def top_prod_def less_eq_prod_def less_prod_def Sup_distl Sup_distr intro: Inf_lower Inf_greatest Sup_upper Sup_least)

interpretation prod: complete_lattice_with_dual Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::complete_lattice_with_dual \<times> 'b::complete_lattice_with_dual)" dual_prod
  by standard (simp_all add: dual_prod_def fun_eq_iff inj_def Sup_prod_def Inf_prod_def inj_dual_iff Sup_dual_def_var image_comp)

interpretation prod: proto_near_quantale Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::proto_near_quantale \<times> 'b::proto_near_quantale)" times_prod'
  by standard (simp add: times_prod'_def Sup_prod_def Sup_distr image_comp)

interpretation prod: proto_quantale Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::proto_quantale \<times> 'b::proto_quantale)" times_prod'
  by standard (simp add: times_prod'_def Sup_prod_def less_eq_prod_def Sup_distl image_comp)

interpretation prod: unital_quantale one_prod times_prod' Inf_prod Sup_prod inf_prod less_eq_prod less_prod sup_prod bot_prod "top_prod :: ('a::unital_quantale \<times> 'b::unital_quantale)"
  by standard (simp_all add: one_prod_def times_prod'_def ac_simps image_comp)

subsection \<open>Quantale Morphisms\<close>

text \<open>There are various ways of defining quantale morphisms, depending on the application. Following Rosenthal,
I present the most important one.\<close>

abbreviation comp_pres :: "('a::times \<Rightarrow> 'b::times) \<Rightarrow> bool" where
  "comp_pres f \<equiv> (\<forall>x y. f (x \<cdot> y) = f x \<cdot> f y)"

abbreviation un_pres :: "('a::one \<Rightarrow> 'b::one) \<Rightarrow> bool" where
  "un_pres f \<equiv> (f 1 = 1)"

definition "comp_closed_set X = (\<forall>x \<in> X. \<forall>y \<in> X. x \<cdot> y \<in> X)"

definition "un_closed_set X = (1 \<in> X)"

definition quantale_homset :: "('a::quantale \<Rightarrow> 'b::quantale) set" where
  "quantale_homset = {f. comp_pres f \<and> Sup_pres f}"

lemma quantale_homset_iff: "f \<in> quantale_homset = (comp_pres f \<and> Sup_pres f)"
  unfolding quantale_homset_def by clarsimp

definition unital_quantale_homset :: "('a::unital_quantale \<Rightarrow> 'b::unital_quantale) set" where
  "unital_quantale_homset = {f. comp_pres f \<and> Sup_pres f \<and> un_pres f}"

lemma unital_quantale_homset_iff: "f \<in> unital_quantale_homset = (comp_pres f \<and> Sup_pres f \<and> un_pres f)"
  unfolding unital_quantale_homset_def by clarsimp

text \<open>Though Infs can be defined from Sups in any quantale, quantale morphisms do not generally preserve Infs.
A different kind of morphism is needed if this is to be guaranteed.\<close>

lemma "f \<in> quantale_homset \<Longrightarrow> Inf_pres f" (*nitpick*)
  oops

text \<open>The images of quantale morphisms are closed under compositions and Sups, hence they form quantales.\<close>

lemma quantale_hom_q_pres: "f \<in> quantale_homset \<Longrightarrow> Sup_closed_set (range f) \<and> comp_closed_set (range f)"
  apply safe
   apply (simp add: Sup_pres_Sup_closed quantale_homset_iff)
  unfolding quantale_homset_iff comp_closed_set_def by (metis (no_types, lifting) imageE range_eqI)

text \<open>Yet the image need not be Inf-closed.\<close>

lemma "f \<in> quantale_homset \<Longrightarrow> Inf_closed_set (range f)" (*nitpick*)
  oops

text \<open>Of course Sups are preserved by quantale-morphisms, hence they are the same in subsets as in the original set.
Infs in the subset, however, exist, since they subset forms a quantale in which Infs can be defined, but these are generally
different from the Infs in the superstructure.

This fact is hidden in Isabelle's definition of complete lattices, where Infs are axiomatised. There is no easy way in general to
show that images of quantale morphisms form quantales, though the statement for Sup-quantales is straightforward. I show this for quantic nuclei
and left-sided elements.\<close>

typedef (overloaded) ('a,'b) quantale_homset = "quantale_homset::('a::quantale \<Rightarrow> 'b::quantale) set"
proof-
  have a: "comp_pres (\<lambda>x::'a::quantale. bot::'b)"
    by simp
  have b: "Sup_pres (\<lambda>x::'a::quantale. bot::'b)"
    unfolding fun_eq_iff comp_def by simp
  hence "(\<lambda>x::'a::quantale. bot::'b) \<in> quantale_homset"
    by (simp add: quantale_homset_iff)
  thus ?thesis
    by auto
qed

setup_lifting type_definition_quantale_homset

text \<open>Interestingly, the following type is not (gobally) inhabited.\<close>

typedef (overloaded) ('a,'b) unital_quantale_homset = "unital_quantale_homset::('a::unital_quantale \<Rightarrow> 'b::unital_quantale) set" (*nitpick*)
  oops

lemma quantale_hom_radj:
  fixes f :: "'a::quantale_with_dual \<Rightarrow> 'b::quantale_with_dual"
  shows "f \<in> quantale_homset \<Longrightarrow> f \<stileturn> radj f"
  unfolding quantale_homset_iff by (simp add: Sup_pres_ladj_aux)

lemma quantale_hom_prop1:
  fixes f :: "'a::quantale_with_dual \<Rightarrow> 'b::quantale_with_dual"
  shows "f \<in> quantale_homset \<Longrightarrow> radj f (f x \<rightarrow> y) = x \<rightarrow> radj f y"
proof-
  assume h: "f \<in> quantale_homset"
  have "f x \<cdot> f (radj f (f x \<rightarrow> y)) \<le> y"
    by (meson h adj_def bres_galois order_refl quantale_hom_radj)
  hence "f (x \<cdot> radj f (f x \<rightarrow> y)) \<le> y"
    by (metis h quantale_homset_iff)
  hence "x \<cdot> radj f (f x \<rightarrow> y) \<le> radj f y"
    using adj_def h quantale_hom_radj by blast
  hence le: "radj f (f x \<rightarrow> y) \<le> x \<rightarrow> radj f y"
    by (simp add: bres_galois)
  have "x \<cdot> (x \<rightarrow> radj f y) \<le> radj f y"
    by (simp add: bres_canc1)
  hence  "f (x \<cdot> (x \<rightarrow> radj f y)) \<le> y"
    using adj_def h quantale_hom_radj by blast
  hence "f x \<cdot> f (x \<rightarrow> radj f y) \<le> y"
    by (metis h quantale_homset_iff)
  hence "f (x \<rightarrow> radj f y) \<le> f x \<rightarrow> y"
    by (simp add: bres_galois)
  hence "x \<rightarrow> radj f y \<le> radj f (f x \<rightarrow> y)"
    using adj_def h quantale_hom_radj by blast
  thus ?thesis
    by (simp add: dual_order.antisym le)
qed

lemma quantale_hom_prop2:
  fixes f :: "'a::quantale_with_dual \<Rightarrow> 'b::quantale_with_dual"
  shows "f \<in> quantale_homset \<Longrightarrow> radj f (y \<leftarrow> f x) = radj f y \<leftarrow> x"
proof-
  assume h: "f \<in> quantale_homset"
  have "f (radj f (y \<leftarrow> f x)) \<cdot> f x \<le> y"
    by (meson adj_def fres_galois h order_refl quantale_hom_radj)
  hence "f (radj f (y \<leftarrow> f x) \<cdot> x) \<le> y"
    by (metis h quantale_homset_iff)
  hence "radj f (y \<leftarrow> f x) \<cdot> x\<le> radj f y"
    using adj_def h quantale_hom_radj by blast
  hence le: "radj f (y \<leftarrow> f x) \<le> radj f y \<leftarrow> x"
    by (simp add: fres_galois)
  have "(radj f y \<leftarrow> x) \<cdot> x \<le> radj f y"
    by (simp add: fres_canc1)
  hence  "f ((radj f y \<leftarrow> x) \<cdot> x) \<le> y"
    using adj_def h quantale_hom_radj by blast
  hence "f (radj f y \<leftarrow> x) \<cdot> f x\<le> y"
    by (metis h quantale_homset_iff)
  hence "f (radj f y \<leftarrow> x) \<le> y \<leftarrow> f x"
    by (simp add: fres_galois)
  hence "radj f y \<leftarrow> x\<le> radj f (y \<leftarrow> f x)"
    using adj_def h quantale_hom_radj by blast
  thus ?thesis
    by (simp add: dual_order.antisym le)
qed

definition quantale_closed_maps :: "('a::quantale \<Rightarrow> 'b::quantale) set" where
  "quantale_closed_maps = {f. (\<forall>x y. f x \<cdot> f y \<le> f (x \<cdot> y))}"

lemma quantale_closed_maps_iff: "f \<in> quantale_closed_maps = (\<forall> x y. f x \<cdot> f y \<le> f (x \<cdot> y))"
  unfolding quantale_closed_maps_def by clarsimp

definition quantale_closed_Sup_maps :: "('a::quantale \<Rightarrow> 'b::quantale) set" where
  "quantale_closed_Sup_maps = {f. (\<forall> x y. f x \<cdot> f y \<le> f (x \<cdot> y)) \<and> Sup_pres f}"

lemma quantale_closed_Sup_maps_iff: "f \<in> quantale_closed_Sup_maps = (\<forall> x y. f x \<cdot> f y \<le> f (x \<cdot> y) \<and> Sup_pres f)"
  unfolding quantale_closed_Sup_maps_def by clarsimp

definition quantale_closed_unital_maps :: "('a::unital_quantale \<Rightarrow> 'b::unital_quantale) set" where
  "quantale_closed_unital_maps = {f. (\<forall> x y. f x \<cdot> f y \<le> f (x \<cdot> y)) \<and> 1 \<le> f 1}"

lemma quantale_closed_unital_maps_iff: "f \<in> quantale_closed_unital_maps = (\<forall> x y. f x \<cdot> f y \<le> f (x \<cdot> y) \<and> 1 \<le> f 1)"
  unfolding quantale_closed_unital_maps_def by clarsimp

definition quantale_closed_unital_Sup_maps :: "('a::unital_quantale \<Rightarrow> 'b::unital_quantale) set" where
  "quantale_closed_unital_Sup_maps = {f. (\<forall> x y. f x \<cdot> f y \<le> f (x \<cdot> y)) \<and> Sup_pres f \<and> 1 \<le> f 1}"

lemma quantale_closed_unital_Sup_maps_iff: "f \<in> quantale_closed_unital_Sup_maps = (\<forall> x y. f x \<cdot> f y \<le> f (x \<cdot> y) \<and> Sup_pres f \<and> 1 \<le> f 1)"
  unfolding quantale_closed_unital_Sup_maps_def by clarsimp

text \<open>Closed maps are the right adjoints of quantale morphisms.\<close>

lemma quantale_hom_closed_map:
  fixes f :: "'a::quantale_with_dual \<Rightarrow> 'b::quantale_with_dual"
  shows "(f \<in> quantale_homset) \<Longrightarrow> (radj f \<in> quantale_closed_maps)"
proof-
  assume h: "f \<in> quantale_homset"
  have "\<forall>x y. f (radj f x) \<cdot> f (radj f y) \<le> x \<cdot> y"
    by (metis adj_def h order_refl psrpq.mult_isol_var quantale_hom_radj)
  hence "\<forall>x y. f (radj f x \<cdot> radj f y) \<le> x \<cdot> y"
    by (metis h quantale_homset_iff)
  hence "\<forall>x y. radj f x \<cdot> radj f y \<le> radj f (x \<cdot> y)"
    using adj_def h quantale_hom_radj by blast
  thus ?thesis
    by (simp add: quantale_closed_maps_iff)
qed

lemma unital_quantale_hom_closed_unital_map:
  fixes f :: "'a::unital_quantale_with_dual \<Rightarrow> 'b::unital_quantale_with_dual"
  shows "(f \<in> unital_quantale_homset) \<Longrightarrow> (radj f \<in> quantale_closed_unital_maps)"
  by (metis (no_types, opaque_lifting) adj_def order_refl quantale_closed_maps_iff quantale_closed_unital_maps_iff quantale_hom_closed_map quantale_hom_radj quantale_homset_iff unital_quantale_homset_iff)

 end