(*
    Author:     Tobias Nipkow, 2008
*)

section "The Gibbard-Satterthwaite Theorem"

theory GS imports Arrow_Order
begin

text\<open>The Gibbard-Satterthwaite theorem as a corollary to Arrow's
theorem. The proof follows Nisan~\cite{NisanRTV07}.\<close>

definition "manipulable f == \<exists>P\<in>Prof. \<exists>i. \<exists>L\<in>Lin. (f P, f(P(i:=L))) : P i"

definition "dict f i == \<forall>P\<in>Prof.\<forall>a. a \<noteq> f P \<longrightarrow> (a,f P) : P i"

definition
 Top :: "alt set \<Rightarrow> pref \<Rightarrow> pref" where
"Top S L \<equiv> {(a,b). (a,b) \<in> L \<and> (a \<in> S \<and> b \<in> S \<or> a \<notin> S \<and> b \<notin> S)} \<union>
             {(a,b). a \<notin> S \<and> b \<in> S}"

lemma Top_in_Lin: "L:Lin \<Longrightarrow> Top S L : Lin"
apply(simp add:Top_def slo_defs Sigma_def)
unfolding trans_def
apply blast
done

lemma Top_in_Prof: "P:Prof \<Longrightarrow> Top S o P : Prof"
by(simp add:Prof_def Pi_def Top_in_Lin)

lemma not_manipulable: "\<not> manipulable f \<longleftrightarrow>
 (\<forall>P\<in>Prof.\<forall>i.\<forall>L\<in>Lin. f P \<noteq> f(P(i:=L)) \<longrightarrow>
   (f(P(i := L)), f P) : P i \<and> (f P, f(P(i := L))) : L)" (is "?A = ?B")
proof
  assume ?A
  show ?B
  proof(clarsimp)
    fix P i L assume 0: "P \<in> Prof" "L \<in> Lin" "f P \<noteq> f (P(i := L))"
    moreover hence 1: "P i: Lin" "P(i:=L): Prof" by(simp add:Prof_def Pi_def)+
    ultimately have "(f (P(i := L)), f P) \<in> P i" (is ?L)
      using \<open>?A\<close> unfolding manipulable_def by (metis notin_Lin_iff)
    moreover have "(f P, f (P(i := L))) \<in> L" (is ?R)
      using 0 1 fun_upd_upd[of P] fun_upd_triv[of P] fun_upd_same[of P]
      using \<open>?A\<close> unfolding manipulable_def by (metis notin_Lin_iff)
    ultimately show "?L \<and> ?R" ..
  qed
next
  assume ?B
  show ?A
  proof(clarsimp simp:manipulable_def)
    fix P i L assume "P \<in> Prof" "L \<in> Lin" "(f P, f (P(i := L))) \<in> P i"
    moreover hence "P i: Lin" by(simp add:Prof_def Pi_def)
    ultimately show False
      using \<open>?B\<close> by(metis Lin_irrefl)
  qed
qed

definition "swf(f) \<equiv> \<lambda>P. {(a,b). a\<noteq>b \<and> f(Top {a,b} o P) = b}"

locale GS =
fixes f
assumes not_manip: "\<not> manipulable f"
and onto: "f ` Prof = UNIV"
begin

lemma mono:
assumes "P\<in>Prof" "P'\<in>Prof" "\<forall>i a. (a, f P) : P i \<longrightarrow> (a, f P) : P' i"
shows "f P' = f P"
proof-
  obtain h :: "indi \<Rightarrow> nat" where
    injh: "inj h" and surjh: "h ` I = {0..<N}"
    by(metis ex_bij_betw_finite_nat[OF finite_indi] bij_betw_def)
  let ?M = "%n i. if h i < n then P' i else P i"
  have N: "!!i. h i < N" using surjh by auto
  have MProf: "!!n. ?M n : Prof" and P'Lin: "!!i. P' i : Lin"
    using \<open>P:Prof\<close> \<open>P':Prof\<close> by(simp add:Prof_def Pi_def)+
  { fix n have "n<=N \<Longrightarrow> f(?M n) = f P"
    proof(induct n)
      case 0 show ?case by simp
    next
      case (Suc n)
      let ?up = "(?M n)(inv h n := P' (inv h n))"
      have 1: "?M(Suc n) = ?up" using surjh Suc(2)
        by(simp (no_asm_simp) add:fun_eq_iff f_inv_into_f)
          (metis injh inv_f_f less_antisym)
      show ?case
      proof(rule ccontr)
        assume "\<not> ?case"
        with \<open>?M(Suc n) = ?up\<close> Suc have 0: "f ?up \<noteq> f(?M n)" by simp
        from nonmanip[OF MProf P'Lin 0] assms(3) show False
          using N surjh Suc Lin_irrefl[OF P'Lin]
          by(fastforce simp: f_inv_into_f)
      qed
    qed
  }
  from this[of N] N show "f P' = f P" by simp
qed

lemma una_Top: assumes "P:Prof" "S \<noteq> {}" shows "f(Top S o P) : S"
proof -
  obtain h :: "indi \<Rightarrow> nat" where
    injh: "inj h" and surjh: "h ` I = {0..<N}"
    by(metis ex_bij_betw_finite_nat[OF finite_indi] bij_betw_def)
  from assms obtain a where "a:S" by blast
  from onto obtain Pa where "Pa:Prof" "f Pa = a"
    by(metis inv_into_into UNIV_I f_inv_into_f)
  let ?M = "%n i. if h i < n then Top S (P i) else Pa i"
  have N: "!!i. h i < N" using surjh by auto
  have MProf: "!!n. ?M n : Prof" using \<open>P:Prof\<close> \<open>Pa:Prof\<close>
    by(simp add:Prof_def Pi_def Top_in_Lin mktop_Lin)
  { fix n have "n<=N \<Longrightarrow> f(?M n) : S"
    proof(induct n)
      case 0 thus ?case using \<open>f Pa = a\<close> \<open>a:S\<close> by simp
    next
      case (Suc n)
      show ?case
      proof cases
        assume "f(?M n) = f(?M(Suc n))"
        thus ?case using Suc by simp
      next
        let ?up = "(?M n)(inv h n := Top S (P(inv h n)))"
        assume "f(?M n) \<noteq> f(?M(Suc n))"
        also have eq: "?M(Suc n) = ?up" using surjh Suc
          by(simp (no_asm_simp) add:fun_eq_iff f_inv_into_f)
            (metis injh inv_f_eq less_antisym)
        finally have n: "f(?M n) \<noteq> f(?up)" .
        with nonmanip[OF MProf Top_in_Lin n[symmetric]] Suc eq \<open>P:Prof\<close>
        show ?case by (simp add:Top_def Prof_def Pi_def)
      qed
    qed
  }
  from this[of N] N show ?thesis by(simp add:comp_def)
qed

lemma SWF_swf: "swf f : SWF"
proof (rule Pi_I)
  fix P assume "P: Prof"
  show "swf f P : Lin"
  proof(unfold Lin_def strict_linear_order_on_def, auto)
    show "total(swf f P)"
    proof(simp add: total_on_def, intro allI impI)
      fix a b :: alt assume "a\<noteq>b"
      thus "(a,b) \<in> swf f P \<or> (b,a) \<in> swf f P"
        unfolding swf_def using una_Top[of P "{a,b}"] \<open>P:Prof\<close>
        by simp(metis insert_commute)
    qed
    show "irrefl(swf f P)" by(simp add: irrefl_def swf_def)
    show "trans(swf f P)"
    proof (clarsimp simp:trans_def swf_def insert_commute)
      fix a b c assume "a\<noteq>b" "b\<noteq>c" "f(Top{a,b} \<circ> P) = b" "f(Top{b,c} \<circ> P) = c"
      hence "a\<noteq>c" by(auto simp: insert_commute)
      note 3 = Top_in_Prof[OF \<open>P:Prof\<close>, of "{a,b,c}"]
      { assume "f (Top {a, b, c} \<circ> P) = a"
        hence "f(Top{a,b} \<circ> P) = a"
          using mono[OF 3 Top_in_Prof[OF \<open>P:Prof\<close>], of "{a,b}"]
          by(auto simp:Top_def)
        with \<open>f(Top{a,b} \<circ> P) = b\<close> \<open>a\<noteq>b\<close> have False by simp
      } moreover
      { assume "f (Top {a, b, c} \<circ> P) = b"
        hence "f(Top{b,c} \<circ> P) = b"
          using mono[OF 3 Top_in_Prof[OF \<open>P:Prof\<close>], of "{b,c}"]
          by(auto simp:Top_def)
        with \<open>f(Top{b,c} \<circ> P) = c\<close> \<open>b\<noteq>c\<close> have False by simp
      }
      ultimately have "f (Top {a, b, c} \<circ> P) = c"
        using una_Top[OF \<open>P:Prof\<close>, of "{a,b,c}", simplified] by blast
      hence "f(Top{a,c} \<circ> P) = c" (is ?R)
        using mono[OF 3 Top_in_Prof[OF \<open>P:Prof\<close>], of "{a,c}"]
        by (auto simp:Top_def)
      thus "a\<noteq>c \<and> ?R" using \<open>a\<noteq>c\<close> by blast
    qed
  qed
qed

lemma Top_top: "L:Lin \<Longrightarrow> (!!a. a\<noteq>b \<Longrightarrow> (a,b) : L) \<Longrightarrow> Top {b} L = L"
apply(auto simp:Top_def slo_defs)
apply (metis trans_def)
apply (metis trans_def)
done

lemma una_swf: "unanimity(swf f)"
proof(clarsimp simp:swf_def unanimity_def)
  fix P a b
  assume "P:Prof" and abP: "\<forall>i. (a, b) \<in> P i"
  hence "a \<noteq> b" by(fastforce simp:Prof_def Pi_def slo_defs)
  let ?abP = "Top {a,b} \<circ> P"
  have "?abP : Prof" using \<open>P:Prof\<close> by(simp add:Prof_def Pi_def Top_in_Lin)
  have top: "!!i c. b\<noteq>c \<Longrightarrow> (c,b) : Top {a,b} (P i)"
    using abP by(auto simp:Top_def)
  have "Top {b} o ?abP = ?abP" using \<open>P:Prof\<close>
    by (simp add:fun_eq_iff top Top_top Prof_def Pi_def Top_in_Lin)
  moreover have "f(Top {b} o ?abP) = b"
    by (metis una_Top[OF \<open>?abP : Prof\<close>] empty_not_insert singletonE)
  ultimately have "f ?abP = b" by simp
  thus "a\<noteq>b \<and> f ?abP = b" using \<open>a\<noteq>b\<close> by blast
qed

lemma IIA_swf: "IIA(swf f)"
proof(clarsimp simp: IIA_def)
  fix P P' a b
  assume "P:Prof" "P':Prof" and iff: "\<forall>i. ((a,b) \<in> P i) = ((a,b) \<in> P' i)"
  hence [simp]: "!!i x. (x,x) ~: P i \<and> (x,x) ~: P' i"
    by(simp add:Prof_def Pi_def slo_defs)
  have iff':  "a\<noteq>b \<longrightarrow> (\<forall>i. ((b,a) \<in> P i) = ((b,a) \<in> P' i))"
    using iff \<open>P:Prof\<close> \<open>P':Prof\<close> unfolding Prof_def Pi_def
    by simp (metis iff notin_Lin_iff)
  let ?abP = "Top {a,b} o P" let ?abP' = "Top {a,b} o P'"
  have "\<forall>i c. (c, f ?abP) : ?abP i \<longrightarrow> (c, f ?abP) : ?abP' i"
    using una_Top[of P "{a,b}", OF \<open>P:Prof\<close>] iff iff' by(auto simp add:Top_def)
  then have "f (Top {a,b} \<circ> P) = f (Top {a,b} \<circ> P')"
    using Top_in_Prof[OF \<open>P:Prof\<close>] Top_in_Prof[OF \<open>P':Prof\<close>]
          mono[of "Top {a, b} \<circ> P"]  by metis
  thus "(a <\<^bsub>swf f P\<^esub> b) = (a <\<^bsub>swf f P'\<^esub> b)" by(simp add: swf_def)
qed

lemma dict_swf: assumes "dictator (swf f) i" shows "dict f i"
proof (auto simp:dict_def)
  fix P a assume "P:Prof" "a\<noteq>f P"
  have "f (Top {a,f P} \<circ> P) = f P"
    using mono[OF \<open>P:Prof\<close> Top_in_Prof[OF \<open>P:Prof\<close>,of "{a,f P}"]]
    by (auto simp:Top_def)
  moreover have "P i = {(a,b). a\<noteq>b \<and> f(Top {a,b} \<circ> P) = b}"
    using assms \<open>P:Prof\<close> by(simp add:dictator_def swf_def)
  ultimately show "(a,f P) : P i" using \<open>a\<noteq>f P\<close> by simp
qed

theorem Gibbard_Satterthwaite:
  "\<exists>i. dict f i"
by (metis Arrow SWF_swf una_swf IIA_swf dict_swf)

end

theorem Gibbard_Satterthwaite:
  "\<not> manipulable f \<Longrightarrow> \<forall>a.\<exists>P\<in>Prof. a = f P \<Longrightarrow> \<exists>i. dict f i"
using GS.Gibbard_Satterthwaite[of f,unfolded GS_def]
by blast

end


section \<open>Euclidean Space: Executability\<close>
theory Executable_Euclidean_Space
imports
  "HOL-Analysis.Multivariate_Analysis"
  "List-Index.List_Index"
  "HOL-Library.Float"
  Affine_Arithmetic_Auxiliarities
begin

subsection \<open>Ordered representation of Basis and Rounding of Components\<close>

class executable_euclidean_space = ordered_euclidean_space +
  fixes Basis_list eucl_down eucl_truncate_down eucl_truncate_up
  assumes eucl_down_def:
    "eucl_down p b = (\<Sum>i \<in> Basis. round_down p (b \<bullet> i) *\<^sub>R i)"
  assumes eucl_truncate_down_def:
    "eucl_truncate_down q b = (\<Sum>i \<in> Basis. truncate_down q (b \<bullet> i) *\<^sub>R i)"
  assumes eucl_truncate_up_def:
    "eucl_truncate_up q b = (\<Sum>i \<in> Basis. truncate_up q (b \<bullet> i) *\<^sub>R i)"
  assumes Basis_list[simp]: "set Basis_list = Basis"
  assumes distinct_Basis_list[simp]: "distinct Basis_list"
begin

lemma length_Basis_list:
  "length Basis_list = card Basis"
  by (metis Basis_list distinct_Basis_list distinct_card)

end

lemma eucl_truncate_down_zero[simp]: "eucl_truncate_down p 0 = 0"
  by (auto simp: eucl_truncate_down_def truncate_down_zero)

lemma eucl_truncate_up_zero[simp]: "eucl_truncate_up p 0 = 0"
  by (auto simp: eucl_truncate_up_def)

subsection \<open>Instantiations\<close>

instantiation real::executable_euclidean_space
begin

definition Basis_list_real :: "real list" where
  "Basis_list_real = [1]"

definition "eucl_down prec b = round_down prec b"
definition "eucl_truncate_down prec b = truncate_down prec b"
definition "eucl_truncate_up prec b = truncate_up prec b"

instance proof qed (auto simp: Basis_list_real_def eucl_down_real_def eucl_truncate_down_real_def
  eucl_truncate_up_real_def)

end

instantiation prod::(executable_euclidean_space, executable_euclidean_space)
  executable_euclidean_space
begin

definition Basis_list_prod :: "('a \<times> 'b) list" where
  "Basis_list_prod =
    zip Basis_list (replicate (length (Basis_list::'a list)) 0) @
    zip (replicate (length (Basis_list::'b list)) 0) Basis_list"

definition "eucl_down p a = (eucl_down p (fst a), eucl_down p (snd a))"
definition "eucl_truncate_down p a = (eucl_truncate_down p (fst a), eucl_truncate_down p (snd a))"
definition "eucl_truncate_up p a = (eucl_truncate_up p (fst a), eucl_truncate_up p (snd a))"

instance
proof
  show "set Basis_list = (Basis::('a*'b) set)"
    by (auto simp: Basis_list_prod_def Basis_prod_def elim!: in_set_zipE)
      (auto simp: Basis_list[symmetric] in_set_zip in_set_conv_nth simp del: Basis_list)
  show "distinct (Basis_list::('a*'b)list)"
    using distinct_Basis_list[where 'a='a] distinct_Basis_list[where 'a='b]
    by (auto simp: Basis_list_prod_def Basis_list intro: distinct_zipI1 distinct_zipI2
      elim!: in_set_zipE)
qed
  (auto simp: eucl_down_prod_def eucl_truncate_down_prod_def eucl_truncate_up_prod_def
    sum_Basis_prod_eq inner_add_left inner_sum_left inner_Basis eucl_down_def
    eucl_truncate_down_def eucl_truncate_up_def
    intro!: euclidean_eqI[where 'a="'a*'b"])

end

lemma eucl_truncate_down_Basis[simp]:
  "i \<in> Basis \<Longrightarrow> eucl_truncate_down e x \<bullet> i = truncate_down e (x \<bullet> i)"
  by (simp add: eucl_truncate_down_def)

lemma eucl_truncate_down_correct:
  "dist (x::'a::executable_euclidean_space) (eucl_down e x) \<in>
    {0..sqrt (DIM('a)) * 2 powr of_int (- e)}"
proof -
  have "dist x (eucl_down e x) = sqrt (\<Sum>i\<in>Basis. (dist (x \<bullet> i) (eucl_down e x \<bullet> i))\<^sup>2)"
    unfolding euclidean_dist_l2[where 'a='a] L2_set_def ..
  also have "\<dots> \<le> sqrt (\<Sum>i\<in>(Basis::'a set). ((2 powr of_int (- e))\<^sup>2))"
    by (intro real_sqrt_le_mono sum_mono power_mono)
      (auto simp: dist_real_def eucl_down_def abs_round_down_le)
  finally show ?thesis
    by (simp add: real_sqrt_mult)
qed

lemma eucl_down: "eucl_down e (x::'a::executable_euclidean_space) \<le> x"
  by (auto simp add: eucl_le[where 'a='a] round_down eucl_down_def)

lemma eucl_truncate_down: "eucl_truncate_down e (x::'a::executable_euclidean_space) \<le> x"
  by (auto simp add: eucl_le[where 'a='a] truncate_down)

lemma eucl_truncate_down_le:
  "x \<le> y \<Longrightarrow> eucl_truncate_down w x \<le> (y::'a::executable_euclidean_space)"
  using eucl_truncate_down
  by (rule order.trans)

lemma eucl_truncate_up_Basis[simp]: "i \<in> Basis \<Longrightarrow> eucl_truncate_up e x \<bullet> i = truncate_up e (x \<bullet> i)"
  by (simp add: eucl_truncate_up_def truncate_up_def)

lemma eucl_truncate_up: "x \<le> eucl_truncate_up e (x::'a::executable_euclidean_space)"
  by (auto simp add: eucl_le[where 'a='a] round_up truncate_up_def)

lemma eucl_truncate_up_le: "x \<le> y \<Longrightarrow> x \<le> eucl_truncate_up e (y::'a::executable_euclidean_space)"
  using _ eucl_truncate_up
  by (rule order.trans)

lemma eucl_truncate_down_mono:
  fixes x::"'a::executable_euclidean_space"
  shows "x \<le> y \<Longrightarrow> eucl_truncate_down p x \<le> eucl_truncate_down p y"
  by (auto simp: eucl_le[where 'a='a] intro!: truncate_down_mono)

lemma eucl_truncate_up_mono:
  fixes x::"'a::executable_euclidean_space"
  shows "x \<le> y \<Longrightarrow> eucl_truncate_up p x \<le> eucl_truncate_up p y"
  by (auto simp: eucl_le[where 'a='a] intro!: truncate_up_mono)

lemma infnorm[code]:
  fixes x::"'a::executable_euclidean_space"
  shows "infnorm x = fold max (map (\<lambda>i. abs (x \<bullet> i)) Basis_list) 0"
  by (auto simp: Max.set_eq_fold[symmetric] infnorm_Max[symmetric] infnorm_pos_le
    intro!: max.absorb2[symmetric])

declare Inf_real_def[code del]
declare Sup_real_def[code del]
declare Inf_prod_def[code del]
declare Sup_prod_def[code del]
declare [[code abort: "Inf::real set \<Rightarrow> real"]]
declare [[code abort: "Sup::real set \<Rightarrow> real"]]
declare [[code abort: "Inf::('a::Inf * 'b::Inf) set \<Rightarrow> 'a * 'b"]]
declare [[code abort: "Sup::('a::Sup * 'b::Sup) set \<Rightarrow> 'a * 'b"]]

lemma nth_Basis_list_in_Basis[simp]:
  "n < length (Basis_list::'a::executable_euclidean_space list) \<Longrightarrow> Basis_list ! n \<in> (Basis::'a set)"
  by (metis Basis_list nth_mem)

subsection \<open>Representation as list\<close>

lemma nth_eq_iff_index:
  "distinct xs \<Longrightarrow> n < length xs \<Longrightarrow> xs ! n = i \<longleftrightarrow> n = index xs i"
  using index_nth_id by fastforce

lemma in_Basis_index_Basis_list: "i \<in> Basis \<Longrightarrow> i = Basis_list ! index Basis_list i"
  by simp

lemmas [simp] = length_Basis_list

lemma sum_Basis_sum_nth_Basis_list:
  "(\<Sum>i\<in>Basis. f i) = (\<Sum>i<DIM('a::executable_euclidean_space). f ((Basis_list::'a list) ! i))"
  apply (rule sum.reindex_cong[OF _ _ refl])
   apply (auto intro!: inj_on_nth)
  by (metis Basis_list image_iff in_Basis_index_Basis_list index_less_size_conv length_Basis_list lessThan_iff)

definition "eucl_of_list xs = (\<Sum>(x, i)\<leftarrow>zip xs Basis_list. x *\<^sub>R i)"

lemma eucl_of_list_nth:
  assumes "length xs = DIM('a)"
  shows "eucl_of_list xs = (\<Sum>i<DIM('a::executable_euclidean_space). (xs ! i) *\<^sub>R ((Basis_list::'a list) ! i))"
  by (auto simp: eucl_of_list_def sum_list_sum_nth length_Basis_list assms atLeast0LessThan)

lemma eucl_of_list_inner:
  fixes i::"'a::executable_euclidean_space"
  assumes i: "i \<in> Basis"
  assumes l: "length xs = DIM('a)"
  shows "eucl_of_list xs \<bullet> i = xs ! (index Basis_list i)"
  by (simp add: eucl_of_list_nth[OF l] inner_sum_left assms inner_Basis
      nth_eq_iff_index sum.delta if_distrib cong: if_cong)

lemma inner_eucl_of_list:
  fixes i::"'a::executable_euclidean_space"
  assumes i: "i \<in> Basis"
  assumes l: "length xs = DIM('a)"
  shows "i \<bullet> eucl_of_list xs = xs ! (index Basis_list i)"
  using eucl_of_list_inner[OF assms] by (auto simp: inner_commute)

definition "list_of_eucl x = map ((\<bullet>) x) Basis_list"

lemma index_Basis_list_nth[simp]:
  "i < DIM('a::executable_euclidean_space) \<Longrightarrow> index Basis_list ((Basis_list::'a list) ! i) = i"
  by (simp add: index_nth_id)

lemma list_of_eucl_eucl_of_list[simp]:
  "length xs = DIM('a::executable_euclidean_space) \<Longrightarrow> list_of_eucl (eucl_of_list xs::'a) = xs"
  by (auto simp: list_of_eucl_def eucl_of_list_inner intro!: nth_equalityI)

lemma eucl_of_list_list_of_eucl[simp]:
  "eucl_of_list (list_of_eucl x) = x"
  by (auto simp: list_of_eucl_def eucl_of_list_inner intro!: euclidean_eqI[where 'a='a])

lemma length_list_of_eucl[simp]: "length (list_of_eucl (x::'a::executable_euclidean_space)) = DIM('a)"
  by (auto simp: list_of_eucl_def)

lemma list_of_eucl_nth[simp]: "n < DIM('a::executable_euclidean_space) \<Longrightarrow> list_of_eucl x ! n = x \<bullet> (Basis_list ! n::'a)"
  by (auto simp: list_of_eucl_def)

lemma nth_ge_len: "n \<ge> length xs \<Longrightarrow> xs ! n = [] ! (n - length xs)"
  by (induction xs arbitrary: n) auto

lemma list_of_eucl_nth_if: "list_of_eucl x ! n = (if n < DIM('a::executable_euclidean_space) then x \<bullet> (Basis_list ! n::'a) else [] ! (n - DIM('a)))"
  apply (auto simp: list_of_eucl_def )
  apply (subst nth_ge_len)
   apply auto
  done

lemma list_of_eucl_eq_iff:
  "list_of_eucl (x::'a::executable_euclidean_space) = list_of_eucl (y::'b::executable_euclidean_space) \<longleftrightarrow>
  (DIM('a) = DIM('b) \<and> (\<forall>i < DIM('b). x \<bullet> Basis_list ! i = y \<bullet> Basis_list ! i))"
  by (auto simp: list_eq_iff_nth_eq)

lemma eucl_of_list_inj: "length xs = DIM('a::executable_euclidean_space) \<Longrightarrow> length ys = DIM('a) \<Longrightarrow>
  (eucl_of_list xs::'a) = eucl_of_list (ys) \<Longrightarrow> xs = ys"
  apply (auto intro!: nth_equalityI simp: euclidean_eq_iff[where 'a="'a"] eucl_of_list_inner)
  using nth_Basis_list_in_Basis[where 'a="'a"]
  by fastforce

lemma eucl_of_list_map_plus[simp]:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
  shows "(eucl_of_list (map (\<lambda>x. f x + g x) xs)::'a) =
    eucl_of_list (map f xs) + eucl_of_list (map g xs)"
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

lemma eucl_of_list_map_uminus[simp]:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
  shows "(eucl_of_list (map (\<lambda>x. - f x) xs)::'a) = - eucl_of_list (map f xs)"
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

lemma eucl_of_list_map_mult_left[simp]:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
  shows "(eucl_of_list (map (\<lambda>x. r * f x) xs)::'a) = r *\<^sub>R eucl_of_list (map f xs)"
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

lemma eucl_of_list_map_mult_right[simp]:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
  shows "(eucl_of_list (map (\<lambda>x. f x * r) xs)::'a) = r *\<^sub>R eucl_of_list (map f xs)"
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

lemma eucl_of_list_map_divide_right[simp]:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
  shows "(eucl_of_list (map (\<lambda>x. f x / r) xs)::'a) = eucl_of_list (map f xs) /\<^sub>R r"
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner divide_simps)

lemma eucl_of_list_map_const[simp]:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)"
  shows "(eucl_of_list (map (\<lambda>x. c) xs)::'a) = c *\<^sub>R One"
  by (auto intro!: euclidean_eqI[where 'a='a] simp: algebra_simps eucl_of_list_inner)

lemma replicate_eq_list_of_eucl_zero: "replicate DIM('a::executable_euclidean_space) 0 = list_of_eucl (0::'a)"
  by (auto intro!: nth_equalityI)

lemma eucl_of_list_append_zeroes[simp]: "eucl_of_list (xs @ replicate n 0) = eucl_of_list xs"
  unfolding eucl_of_list_def
  apply (auto simp: sum_list_sum_nth)
  apply (rule sum.mono_neutral_cong_right)
  by (auto simp: nth_append)

lemma Basis_prodD:
  assumes "(i, j) \<in> Basis"
  shows "i \<in> Basis \<and> j = 0 \<or> i = 0 \<and> j \<in> Basis"
  using assms
  by (auto simp: Basis_prod_def)

lemma eucl_of_list_take_DIM[simp]:
  assumes "d = DIM('b::executable_euclidean_space)"
  shows "(eucl_of_list (take d xs)::'b) = (eucl_of_list xs)"
  by (auto simp: eucl_of_list_inner eucl_of_list_def fst_sum_list sum_list_sum_nth assms dest!: Basis_prodD)

lemma eucl_of_list_eqI:
  assumes "take DIM('a) (xs @ replicate (DIM('a) - length xs) 0) =
    take DIM('a) (ys @ replicate (DIM('a) - length ys) 0)"
  shows "eucl_of_list xs = (eucl_of_list ys::'a::executable_euclidean_space)"
proof -
  have "(eucl_of_list xs::'a) = eucl_of_list (take DIM('a) (xs @ replicate (DIM('a) - length xs) 0))"
    by (simp add: )
  also note assms
  also have "eucl_of_list (take DIM('a) (ys @ replicate (DIM('a) - length ys) 0)) = (eucl_of_list ys::'a)"
    by simp
  finally show ?thesis .
qed

lemma eucl_of_list_replicate_zero[simp]: "eucl_of_list (replicate E 0) = 0"
proof -
  have "eucl_of_list (replicate E 0) = (eucl_of_list (replicate E 0 @ replicate (DIM('a) - E) 0)::'a)"
    by simp
  also have "\<dots> = eucl_of_list (replicate DIM('a) 0)"
    apply (rule eucl_of_list_eqI)
    by (auto simp: min_def nth_append intro!: nth_equalityI)
  also have "\<dots> = 0"
    by (simp add: replicate_eq_list_of_eucl_zero)
  finally show ?thesis by simp
qed

lemma eucl_of_list_Nil[simp]: "eucl_of_list [] = 0"
  using eucl_of_list_replicate_zero[of 0] by simp

lemma fst_eucl_of_list_prod:
  shows "fst (eucl_of_list xs::'b::executable_euclidean_space  \<times> _) = (eucl_of_list (take DIM('b) xs)::'b)"
  apply (auto simp: eucl_of_list_inner eucl_of_list_def fst_sum_list dest!: Basis_prodD)
  apply (simp add: sum_list_sum_nth)
  apply (rule sum.mono_neutral_cong_right)
  subgoal by simp
  subgoal by auto
  subgoal by (auto simp: Basis_list_prod_def nth_append)
  subgoal by (auto simp: Basis_list_prod_def nth_append)
  done

lemma index_zip_replicate2[simp]: "index (zip as (replicate d b)) (a, b) = index as a"
  if "d = length as"
  using that
  by (induction as arbitrary: d) auto

lemma index_Basis_list_prod[simp]:
  fixes a::"'a::executable_euclidean_space" and b::"'b::executable_euclidean_space"
  shows "a \<in> Basis \<Longrightarrow> index Basis_list (a, 0::'b) = index Basis_list a"
    "b \<in> Basis \<Longrightarrow> index Basis_list (0::'a, b) = DIM('a) + index Basis_list b"
  by (auto simp: Basis_list_prod_def index_append
      in_set_zip zip_replicate index_map_inj dest: spec[where x="index Basis_list a"])

lemma eucl_of_list_eq_takeI:
  assumes "(eucl_of_list (take DIM('a::executable_euclidean_space) xs)::'a) = x"
  shows "eucl_of_list xs = x"
  using eucl_of_list_take_DIM[OF refl, of xs, where 'b='a] assms
  by auto

lemma eucl_of_list_inner_le:
  fixes i::"'a::executable_euclidean_space"
  assumes i: "i \<in> Basis"
  assumes l: "length xs \<ge> DIM('a)"
  shows "eucl_of_list xs \<bullet> i = xs ! (index Basis_list i)"
proof -
  have "(eucl_of_list xs::'a) = eucl_of_list (take DIM('a) (xs @ (replicate (DIM('a) - length xs) 0)))"
    by (rule eucl_of_list_eq_takeI) simp
  also have "\<dots> \<bullet> i = xs ! (index Basis_list i)"
    using assms
    by (subst eucl_of_list_inner) auto
  finally show ?thesis .
qed

lemma eucl_of_list_prod_if:
  assumes "length xs = DIM('a::executable_euclidean_space) + DIM('b::executable_euclidean_space)"
  shows "eucl_of_list xs =
    (eucl_of_list (take DIM('a) xs)::'a, eucl_of_list (drop DIM('a) xs)::'b)"
  apply (rule euclidean_eqI)
  using assms
  apply (auto simp: eucl_of_list_inner dest!: Basis_prodD)
   apply (subst eucl_of_list_inner_le)
  apply (auto simp: Basis_list_prod_def index_append in_set_zip)
  done

lemma snd_eucl_of_list_prod:
  shows "snd (eucl_of_list xs::'b::executable_euclidean_space  \<times> 'c::executable_euclidean_space) =
    (eucl_of_list (drop DIM('b) xs)::'c)"
proof (cases "length xs \<le> DIM('b)")
  case True
  then show ?thesis
    by (auto simp: eucl_of_list_inner eucl_of_list_def snd_sum_list dest!: Basis_prodD)
      (simp add: sum_list_sum_nth Basis_list_prod_def nth_append)
next
  case False
  have "xs = take DIM('b) xs @ drop DIM('b) xs" by simp
  also have "eucl_of_list \<dots> = (eucl_of_list (\<dots> @ replicate (length xs - DIM('c)) 0)::'b \<times> 'c)"
    by simp
  finally have "eucl_of_list xs = (eucl_of_list (xs @ replicate (DIM('b) + DIM('c) - length xs) 0)::'b \<times> 'c)"
    by simp
  also have "\<dots> = eucl_of_list (take (DIM ('b \<times> 'c)) (xs @ replicate (DIM('b) + DIM('c) - length xs) 0))"
    by (simp add: )
  finally have *: "(eucl_of_list xs::'b\<times>'c) = eucl_of_list (take DIM('b \<times> 'c) (xs @ replicate (DIM('b) + DIM('c) - length xs) 0))"
    by simp
  show ?thesis
    apply (subst *)
    apply (subst eucl_of_list_prod_if)
    subgoal by simp
    subgoal
      apply simp
      apply (subst (2) eucl_of_list_take_DIM[OF refl, symmetric])
      apply (subst (2) eucl_of_list_take_DIM[OF refl, symmetric])
      apply (rule arg_cong[where f=eucl_of_list])
      by (auto intro!: nth_equalityI simp: nth_append min_def split: if_splits)
    done
qed

lemma eucl_of_list_prod:
  shows "eucl_of_list xs = (eucl_of_list (take DIM('b) xs)::'b::executable_euclidean_space,
    eucl_of_list (drop DIM('b) xs)::'c::executable_euclidean_space)"
  using snd_eucl_of_list_prod[of xs, where 'b='b and 'c='c]
  using fst_eucl_of_list_prod[of xs, where 'b='b and 'a='c]
  by (auto simp del: snd_eucl_of_list_prod fst_eucl_of_list_prod simp add: prod_eq_iff)

lemma eucl_of_list_real[simp]: "eucl_of_list [x] = (x::real)"
  by (auto simp: eucl_of_list_def Basis_list_real_def)

lemma eucl_of_list_append[simp]:
  assumes "length xs = DIM('i::executable_euclidean_space)"
  assumes "length ys = DIM('j::executable_euclidean_space)"
  shows "eucl_of_list (xs @ ys) = (eucl_of_list xs::'i, eucl_of_list ys::'j)"
  using assms
  by (auto simp: eucl_of_list_prod)

lemma list_allI: "(\<And>x. x \<in> set xs \<Longrightarrow> P x) \<Longrightarrow> list_all P xs"
  by (auto simp: list_all_iff)

lemma
  concat_map_nthI:
  assumes "\<And>x y. x \<in> set xs \<Longrightarrow> y \<in> set (f x) \<Longrightarrow> P y"
  assumes "j < length (concat (map f xs))"
  shows "P (concat (map f xs) ! j)"
proof -
  have "list_all P (concat (map f xs))"
    by (rule list_allI) (auto simp: assms)
  then show ?thesis
    by (auto simp: list_all_length assms)
qed

lemma map_nth_append1:
  assumes "length xs = d"
  shows "map ((!) (xs @ ys)) [0..<d] = xs"
  using assms
  by (auto simp: nth_append intro!: nth_equalityI)

lemma map_nth_append2:
  assumes "length ys = d"
  shows "map ((!) (xs @ ys)) [length xs..<length xs + d] = ys"
  using assms
  by (auto simp: intro!: nth_equalityI)

lemma length_map2 [simp]: "length (map2 f xs ys) = min (length xs) (length ys)"
  by simp

lemma map2_nth [simp]: "map2 f xs ys ! n = f (xs ! n) (ys ! n)"
  if "n < length xs" "n < length ys"
  using that by simp

lemma list_of_eucl_add: "list_of_eucl (x + y) = map2 (+) (list_of_eucl x) (list_of_eucl y)"
  by (auto intro!: nth_equalityI simp: inner_simps)

lemma list_of_eucl_inj:
  "list_of_eucl z = list_of_eucl y \<Longrightarrow> y = z"
  by (metis eucl_of_list_list_of_eucl)

lemma length_Basis_list_pos[simp]: "length Basis_list > 0"
  by (metis length_pos_if_in_set Basis_list SOME_Basis)

lemma Basis_list_nth_nonzero:
  "i < length (Basis_list::'a::executable_euclidean_space list) \<Longrightarrow> (Basis_list::'a list) ! i \<noteq> 0"
  by (auto dest!: nth_mem simp: nonzero_Basis)

lemma nth_Basis_list_prod:
  "i < DIM('a) + DIM('b) \<Longrightarrow> (Basis_list::('a::executable_euclidean_space \<times> 'b::executable_euclidean_space) list) ! i =
    (if i < DIM('a) then (Basis_list ! i, 0) else (0, Basis_list ! (i - DIM('a))))"
  by (auto simp: Basis_list_nth_nonzero prod_eq_iff Basis_list_prod_def nth_append not_less)

lemma eucl_of_list_if:
  assumes [simp]: "length xs = DIM('a::executable_euclidean_space)" "distinct xs"
  shows "eucl_of_list (map (\<lambda>xa. if xa = x then 1 else 0) (xs::nat list)) =
    (if x \<in> set xs then Basis_list ! index xs x else 0::'a)"
  by (rule euclidean_eqI) (auto simp: eucl_of_list_inner inner_Basis index_nth_id)

lemma take_append_take_minus_idem: "take n XS @ map ((!) XS) [n..<length XS] = XS"
  by (auto intro!: nth_equalityI simp: nth_append min_def)

lemma sum_list_Basis_list[simp]: "sum_list (map f Basis_list) = (\<Sum>b\<in>Basis. f b)"
  by (subst sum_list_distinct_conv_sum_set) (auto simp: Basis_list distinct_Basis_list)

lemma hd_Basis_list[simp]: "hd Basis_list \<in> Basis"
  unfolding Basis_list[symmetric]
  by (rule hd_in_set) (auto simp: set_empty[symmetric])

definition "inner_lv_rel a b = sum_list (map2 (*) a b)"

lemma eucl_of_list_inner_eq: "(eucl_of_list xs::'a) \<bullet> eucl_of_list ys = inner_lv_rel xs ys"
  if "length xs = DIM('a::executable_euclidean_space)" "length ys = DIM('a)"
  using that
  by (subst euclidean_inner[abs_def], subst sum_list_Basis_list[symmetric])
      (auto simp: eucl_of_list_inner sum_list_sum_nth index_nth_id inner_lv_rel_def)

lemma euclidean_vec_componentwise:
  "(\<Sum>(xa::'a::euclidean_space^'b::finite)\<in>Basis. f xa) = (\<Sum>a\<in>Basis. (\<Sum>b::'b\<in>UNIV. f (axis b a)))"
  apply (auto simp: Basis_vec_def)
  apply (subst sum.swap)
  apply (subst sum.Union_disjoint)
    apply auto
      apply (simp add: axis_eq_axis nonzero_Basis)
   apply (simp add: axis_eq_axis nonzero_Basis)
  apply (subst sum.reindex)
   apply (auto intro!: injI)
  subgoal
    apply (auto simp: set_eq_iff)
    by (metis (full_types) all_not_in_conv inner_axis_axis inner_eq_zero_iff nonempty_Basis nonzero_Basis)
  apply (rule sum.cong[OF refl])
  apply (auto )
  apply (rule sum.reindex_cong[OF _ _ refl])
  apply (auto intro!: inj_onI)
  using axis_eq_axis by blast

lemma vec_nth_inner_scaleR_craziness:
  "f (x $ i \<bullet> j) *\<^sub>R j = (\<Sum>xa\<in>UNIV. f (x $ xa \<bullet> j) *\<^sub>R axis xa j) $ i"
  by vector (auto simp: axis_def if_distrib scaleR_vec_def sum.delta' cong: if_cong)

instantiation vec :: ("{executable_euclidean_space}", enum) executable_euclidean_space
begin

definition Basis_list_vec :: "('a, 'b) vec list" where
  "Basis_list_vec = concat (map (\<lambda>n. map (axis n) Basis_list) enum_class.enum)"

definition eucl_down_vec :: "int \<Rightarrow> ('a, 'b) vec \<Rightarrow> ('a, 'b) vec" where
  "eucl_down_vec p x = (\<chi> i. eucl_down p (x $ i))"

definition eucl_truncate_down_vec :: "nat \<Rightarrow> ('a, 'b) vec \<Rightarrow> ('a, 'b) vec" where
  "eucl_truncate_down_vec p x = (\<chi> i. eucl_truncate_down p (x $ i))"

definition eucl_truncate_up_vec :: "nat \<Rightarrow> ('a, 'b) vec \<Rightarrow> ('a, 'b) vec" where
  "eucl_truncate_up_vec p x = (\<chi> i. eucl_truncate_up p (x $ i))"

instance
proof
  show *: "set (Basis_list::('a, 'b) vec list) = Basis"
    unfolding Basis_list_vec_def Basis_vec_def
    apply (auto simp: Basis_list_vec_def vec_eq_iff distinct_map Basis_vec_def
        intro!: distinct_concat inj_onI split: if_splits)
    apply (auto simp: Basis_list_vec_def vec_eq_iff distinct_map enum_distinct
        UNIV_enum[symmetric]
        intro!: distinct_concat inj_onI split: if_splits)
    done
  have "length (Basis_list::('a, 'b) vec list) = CARD('b) * DIM('a)"
    by (auto simp: Basis_list_vec_def length_concat o_def enum_distinct
        sum_list_distinct_conv_sum_set UNIV_enum[symmetric])
  then show "distinct (Basis_list::('a, 'b) vec list)"
    using * by (auto intro!: card_distinct)
qed (simp_all only: vector_cart[symmetric] vec_eq_iff
    eucl_down_vec_def eucl_down_def
    eucl_truncate_down_vec_def eucl_truncate_down_def
    eucl_truncate_up_vec_def eucl_truncate_up_def,
    auto simp: euclidean_vec_componentwise inner_axis Basis_list_vec_def
    vec_nth_inner_scaleR_craziness
    intro!: sum.cong[OF refl])
end

lemma concat_same_lengths_nth:
  assumes "\<And>xs. xs \<in> set XS \<Longrightarrow> length xs = N"
  assumes "i < length XS * N" "N > 0"
  shows "concat XS ! i = XS ! (i div N) ! (i mod N)"
  using assms
  apply (induction XS arbitrary: i)
   apply (auto simp: nth_append nth_Cons split: nat.splits)
   apply (simp add: div_eq_0_iff)
  by (metis Suc_inject div_geq mod_geq)

lemma concat_map_map_index:
  shows "concat (map (\<lambda>n. map (f n) xs) ys) =
    map (\<lambda>i. f (ys ! (i div length xs)) (xs ! (i mod length xs))) [0..<length xs * length ys]"
  apply (auto intro!: nth_equalityI simp: length_concat o_def sum_list_sum_nth)
  apply (subst concat_same_lengths_nth)
     apply (auto simp: )
  apply (subst nth_map_upt)
  apply (auto simp: ac_simps)
  apply (subst nth_map)
  apply (metis div_eq_0_iff div_mult2_eq mult.commute mult_0 not_less0)
  apply (subst nth_map)
  subgoal for i
    using gr_implies_not_zero by fastforce
  subgoal by simp
  done

lemma
  sum_list_zip_map:
  assumes "distinct xs"
  shows "(\<Sum>(x, y)\<leftarrow>zip xs (map g xs). f x y) = (\<Sum>x\<in>set xs. f x (g x))"
  by (force simp add: sum_list_distinct_conv_sum_set assms distinct_zipI1 split_beta'
    in_set_zip in_set_conv_nth inj_on_convol_ident
    intro!: sum.reindex_cong[where l="\<lambda>x. (x, g x)"])

lemma
  sum_list_zip_map_of:
  assumes "distinct bs"
  assumes "length xs = length bs"
  shows "(\<Sum>(x, y)\<leftarrow>zip xs bs. f x y) = (\<Sum>x\<in>set bs. f (the (map_of (zip bs xs) x)) x)"
proof -
  have "(\<Sum>(x, y)\<leftarrow>zip xs bs. f x y) = (\<Sum>(y, x)\<leftarrow>zip bs xs. f x y)"
    by (subst zip_commute) (auto simp: o_def split_beta')
  also have "\<dots> = (\<Sum>(x, y)\<leftarrow>zip bs (map (the o map_of (zip bs xs)) bs). f y x)"
  proof (rule arg_cong, rule map_cong)
    have "xs = (map (the \<circ> map_of (zip bs xs)) bs)"
      using assms
      by (auto intro!: nth_equalityI simp: map_nth map_of_zip_nth)
    then show "zip bs xs = zip bs (map (the \<circ> map_of (zip bs xs)) bs)"
      by simp
  qed auto
  also have "\<dots> = (\<Sum>x\<in>set bs. f (the (map_of (zip bs xs) x)) x)"
    using assms(1)
    by (subst sum_list_zip_map) (auto simp: o_def)
  finally show ?thesis .
qed

lemma vec_nth_matrix:
  "vec_nth (vec_nth (matrix y) i) j = vec_nth (y (axis j 1)) i"
  unfolding matrix_def by simp

lemma matrix_eqI:
  assumes "\<And>x. x \<in> Basis \<Longrightarrow> A *v x = B *v x"
  shows "(A::real^'n^'n) = B"
  apply vector
  using assms
  apply (auto simp: Basis_vec_def)
  by (metis cart_eq_inner_axis matrix_vector_mul_component)

lemma matrix_columnI:
  assumes "\<And>i. column i A = column i B"
  shows "(A::real^'n^'n) = B"
  using assms
  apply vector
  apply (auto simp: column_def)
  apply vector
  by (metis iso_tuple_UNIV_I vec_lambda_inject)

lemma
  vec_nth_Basis:
  fixes x::"real^'n"
  shows "x \<in> Basis \<Longrightarrow> vec_nth x i = (if x = axis i 1 then 1 else 0)"
  apply (auto simp: Basis_vec_def)
  by (metis cart_eq_inner_axis inner_axis_axis)

lemma vec_nth_eucl_of_list_eq: "length M = CARD('n) \<Longrightarrow>
  vec_nth (eucl_of_list M::real^'n::enum) i = M ! index Basis_list (axis i (1::real))"
  apply (auto simp: eucl_of_list_def)
  apply (subst sum_list_zip_map_of)
   apply (auto intro!: distinct_zipI2 simp: split_beta')
  apply (subst sum.cong[OF refl])
   apply (subst vec_nth_Basis)
    apply (force simp: set_zip)
  apply (rule refl)
  apply (auto simp: if_distrib sum.delta cong: if_cong)
  subgoal
    apply (cases "map_of (zip Basis_list M) (axis i 1::real^'n::enum)")
    subgoal premises prems
    proof -
      have "fst ` set (zip Basis_list M) = (Basis::(real^'n::enum) set)" using prems
        by (auto simp: in_set_zip)
      then show ?thesis
        using prems
        by (subst (asm) map_of_eq_None_iff) simp
    qed
    subgoal for a
      apply (auto simp: in_set_zip)
      subgoal premises prems for n
        by (metis DIM_cart DIM_real index_Basis_list_nth mult.right_neutral prems(2) prems(3))
      done
    done
  done

lemma index_Basis_list_axis1: "index Basis_list (axis i (1::real)) = index enum_class.enum i"
  apply (auto simp: Basis_list_vec_def Basis_list_real_def )
  apply (subst index_map_inj)
  by (auto intro!: injI simp: axis_eq_axis)

lemma vec_nth_eq_list_of_eucl1:
  "(vec_nth (M::real^'n::enum) i) = list_of_eucl M ! (index enum_class.enum i)"
  apply (subst eucl_of_list_list_of_eucl[of M, symmetric])
  apply (subst vec_nth_eucl_of_list_eq)
  unfolding index_Basis_list_axis1
  by auto

lemma enum_3[simp]: "(enum_class.enum::3 list) = [0, 1, 2]"
  by code_simp+

lemma three_eq_zero: "(3::3) = 0" by simp

lemma forall_3': "(\<forall>i::3. P i) \<longleftrightarrow> P 0 \<and> P 1 \<and> P 2"
  using forall_3 three_eq_zero by auto

lemma axis_one_neq_zero[simp]: "axis xa (1::'a::zero_neq_one) \<noteq> 0"
  by (auto simp: axis_def vec_eq_iff)

type_synonym R3 = "real*real*real"

lemma Basis_list_R3: "Basis_list = [(1,0,0), (0, 1, 0), (0, 0, 1)::R3]"
  by (auto simp: Basis_list_prod_def Basis_list_real_def zero_prod_def)

lemma Basis_list_vec3: "Basis_list = [axis 0 1::real^3, axis 1 1, axis 2 1]"
  by (auto simp: Basis_list_vec_def Basis_list_real_def)

lemma eucl_of_list3[simp]: "eucl_of_list [a, b, c] = (a, b, c)"
  by (auto simp: eucl_of_list_inner Basis_list_vec_def zero_prod_def
      Basis_prod_def Basis_list_vec3 Basis_list_R3
      intro!: euclidean_eqI[where 'a=R3])

subsection \<open>Bounded Linear Functions\<close>

subsection \<open>bounded linear functions\<close>

locale blinfun_syntax
begin
no_notation vec_nth (infixl "$" 90)
notation blinfun_apply (infixl "$" 999)
end

lemma bounded_linear_via_derivative:
  fixes f::"'a::real_normed_vector \<Rightarrow> 'b::euclidean_space \<Rightarrow>\<^sub>L 'c::real_normed_vector" \<comment> \<open>TODO: generalize?\<close>
  assumes "\<And>i. ((\<lambda>x. blinfun_apply (f x) i) has_derivative (\<lambda>x. f' y x i)) (at y)"
  shows "bounded_linear (f' y x)"
proof -
  interpret linear "f' y x"
  proof (unfold_locales, goal_cases)
    case (1 v w)
    from has_derivative_unique[OF assms[of "v + w", unfolded blinfun.bilinear_simps]
      has_derivative_add[OF assms[of v] assms[of w]], THEN fun_cong, of x]
    show ?case .
  next
    case (2 r v)
    from has_derivative_unique[OF assms[of "r *\<^sub>R v", unfolded blinfun.bilinear_simps]
      has_derivative_scaleR_right[OF assms[of v], of r], THEN fun_cong, of x]
    show ?case .
  qed
  let ?bnd = "\<Sum>i\<in>Basis. norm (f' y x i)"
  {
    fix v
    have "f' y x v = (\<Sum>i\<in>Basis. (v \<bullet> i) *\<^sub>R f' y x i)"
      by (subst euclidean_representation[symmetric]) (simp add: sum scaleR)
    also have "norm \<dots> \<le> norm v * ?bnd"
      by (auto intro!: order.trans[OF norm_sum] sum_mono mult_right_mono
        simp: sum_distrib_left Basis_le_norm)
    finally have "norm (f' y x v) \<le> norm v * ?bnd" .
  }
  then show ?thesis by unfold_locales auto
qed

definition blinfun_scaleR::"('a::real_normed_vector \<Rightarrow>\<^sub>L real) \<Rightarrow> 'b::real_normed_vector \<Rightarrow> ('a \<Rightarrow>\<^sub>L 'b)"
  where "blinfun_scaleR a b = blinfun_scaleR_left b o\<^sub>L a"

lemma blinfun_scaleR_transfer[transfer_rule]:
  "rel_fun (pcr_blinfun (=) (=)) (rel_fun (=) (pcr_blinfun (=) (=)))
    (\<lambda>a b c. a c *\<^sub>R b) blinfun_scaleR"
  by (auto simp: blinfun_scaleR_def rel_fun_def pcr_blinfun_def cr_blinfun_def OO_def)

lemma blinfun_scaleR_rep_eq[simp]:
  "blinfun_scaleR a b c = a c *\<^sub>R b"
  by (simp add: blinfun_scaleR_def)

lemma bounded_linear_blinfun_scaleR: "bounded_linear (blinfun_scaleR a)"
  unfolding blinfun_scaleR_def[abs_def]
  by (auto intro!: bounded_linear_intros)

lemma blinfun_scaleR_has_derivative[derivative_intros]:
  assumes "(f has_derivative f') (at x within s)"
  shows "((\<lambda>x. blinfun_scaleR a (f x)) has_derivative (\<lambda>x. blinfun_scaleR a (f' x))) (at x within s)"
  using bounded_linear_blinfun_scaleR assms
  by (rule bounded_linear.has_derivative)

lemma blinfun_componentwise:
  fixes f::"'a::real_normed_vector \<Rightarrow> 'b::euclidean_space \<Rightarrow>\<^sub>L 'c::real_normed_vector"
  shows "f = (\<lambda>x. \<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f x i))"
  by (auto intro!: blinfun_eqI
    simp: blinfun.sum_left euclidean_representation blinfun.scaleR_right[symmetric]
      blinfun.sum_right[symmetric])

lemma
  blinfun_has_derivative_componentwiseI:
  fixes f::"'a::real_normed_vector \<Rightarrow> 'b::euclidean_space \<Rightarrow>\<^sub>L 'c::real_normed_vector"
  assumes "\<And>i. i \<in> Basis \<Longrightarrow> ((\<lambda>x. f x i) has_derivative blinfun_apply (f' i)) (at x)"
  shows "(f has_derivative (\<lambda>x. \<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f' i x))) (at x)"
  by (subst blinfun_componentwise) (force intro: derivative_eq_intros assms simp: blinfun.bilinear_simps)

lemma
  has_derivative_BlinfunI:
  fixes f::"'a::real_normed_vector \<Rightarrow> 'b::euclidean_space \<Rightarrow>\<^sub>L 'c::real_normed_vector"
  assumes "\<And>i. ((\<lambda>x. f x i) has_derivative (\<lambda>x. f' y x i)) (at y)"
  shows "(f has_derivative (\<lambda>x. Blinfun (f' y x))) (at y)"
proof -
  have 1: "f = (\<lambda>x. \<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f x i))"
    by (rule blinfun_componentwise)
  moreover have 2: "(\<dots> has_derivative (\<lambda>x. \<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f' y x i))) (at y)"
    by (force intro: assms derivative_eq_intros)
  moreover
  interpret f': bounded_linear "f' y x" for x
    by (rule bounded_linear_via_derivative) (rule assms)
  have 3: "(\<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (f' y x i)) i = f' y x i" for x i
    by (auto simp: if_distrib if_distribR blinfun.bilinear_simps
      f'.scaleR[symmetric] f'.sum[symmetric] euclidean_representation
      intro!: blinfun_euclidean_eqI)
  have 4: "blinfun_apply (Blinfun (f' y x)) = f' y x" for x
    apply (subst bounded_linear_Blinfun_apply)
    subgoal by unfold_locales
    subgoal by simp
    done
  show ?thesis
    apply (subst 1)
    apply (rule 2[THEN has_derivative_eq_rhs])
    apply (rule ext)
    apply (rule blinfun_eqI)
    apply (subst 3)
    apply (subst 4)
    apply (rule refl)
    done
qed

lemma
  has_derivative_Blinfun:
  assumes "(f has_derivative f') F"
  shows "(f has_derivative Blinfun f') F"
  using assms
  by (subst bounded_linear_Blinfun_apply) auto

lift_definition flip_blinfun::
  "('a::real_normed_vector \<Rightarrow>\<^sub>L 'b::real_normed_vector \<Rightarrow>\<^sub>L 'c::real_normed_vector) \<Rightarrow> 'b \<Rightarrow>\<^sub>L 'a \<Rightarrow>\<^sub>L 'c" is
  "\<lambda>f x y. f y x"
  using bounded_bilinear.bounded_linear_left bounded_bilinear.bounded_linear_right bounded_bilinear.flip
  by auto

lemma flip_blinfun_apply[simp]: "flip_blinfun f a b = f b a"
  by transfer simp

lemma le_norm_blinfun:
  shows "norm (blinfun_apply f x) / norm x \<le> norm f"
  by transfer (rule le_onorm)

lemma norm_flip_blinfun[simp]: "norm (flip_blinfun x) = norm x" (is "?l = ?r")
proof (rule antisym)
  from order_trans[OF norm_blinfun, OF mult_right_mono, OF norm_blinfun, OF norm_ge_zero, of x]
  show "?l \<le> ?r"
    by (auto intro!: norm_blinfun_bound simp: ac_simps)
  have "norm (x a b) \<le> norm (flip_blinfun x) * norm a * norm b" for a b
  proof -
    have "norm (x a b) / norm a \<le> norm (flip_blinfun x b)"
      by (rule order_trans[OF _ le_norm_blinfun]) auto
    also have "\<dots> \<le> norm (flip_blinfun x) * norm b"
      by (rule norm_blinfun)
    finally show ?thesis
      by (auto simp add: divide_simps blinfun.bilinear_simps algebra_simps split: if_split_asm)
  qed
  then show "?r \<le> ?l"
    by (auto intro!: norm_blinfun_bound)
qed

lemma bounded_linear_flip_blinfun[bounded_linear]: "bounded_linear flip_blinfun"
  by unfold_locales (auto simp: blinfun.bilinear_simps intro!: blinfun_eqI exI[where x=1])

lemma dist_swap2_swap2[simp]: "dist (flip_blinfun f) (flip_blinfun g) = dist f g"
  by (metis (no_types) bounded_linear_flip_blinfun dist_blinfun_def linear_simps(2)
    norm_flip_blinfun)

context includes blinfun.lifting begin

lift_definition blinfun_of_vmatrix::"(real^'m^'n) \<Rightarrow> ((real^('m::finite)) \<Rightarrow>\<^sub>L (real^('n::finite)))" is
  "matrix_vector_mult:: ((real, 'm) vec, 'n) vec \<Rightarrow> ((real, 'm) vec \<Rightarrow> (real, 'n) vec)"
  unfolding linear_linear
  by (rule matrix_vector_mul_linear)

lemma matrix_blinfun_of_vmatrix[simp]: "matrix (blinfun_of_vmatrix M) = M"
  apply vector
  apply (auto simp: matrix_def)
  apply transfer
  by (metis cart_eq_inner_axis matrix_vector_mul_component)

end

lemma blinfun_apply_componentwise:
  "B = (\<Sum>i\<in>Basis. blinfun_scaleR (blinfun_inner_left i) (blinfun_apply B i))"
  using blinfun_componentwise[of "\<lambda>x. B", unfolded fun_eq_iff]
  by blast

lemma blinfun_apply_eq_sum:
  assumes [simp]: "length v = CARD('n)"
  shows "blinfun_apply (B::(real^'n::enum)\<Rightarrow>\<^sub>L(real^'m::enum)) (eucl_of_list v) =
    (\<Sum>i<CARD('m). \<Sum>j<CARD('n). ((B (Basis_list ! j) \<bullet> Basis_list ! i) * v ! j) *\<^sub>R (Basis_list ! i))"
  apply (subst blinfun_apply_componentwise[of B])
  apply (auto intro!: euclidean_eqI[where 'a="(real,'m) vec"]
      simp: blinfun.bilinear_simps eucl_of_list_inner inner_sum_left inner_Basis if_distrib
        sum_Basis_sum_nth_Basis_list nth_eq_iff_index if_distribR
        cong: if_cong)
  apply (subst sum.swap)
  by (auto simp: sum.delta algebra_simps)

lemma in_square_lemma[intro, simp]: "x * C + y < D * C" if "x < D" "y < C" for x::nat
proof -
  have "x * C + y < (D - 1) * C + C"
    apply (rule add_le_less_mono)
     apply (rule mult_right_mono)
    using that
    by auto
  also have "\<dots> \<le> D * C"
    using that
    by (auto simp: algebra_simps)
  finally show ?thesis .
qed

lemma less_square_imp_div_less[intro, simp]: "i < E * D \<Longrightarrow>  i div E < D" for i::nat
  by (metis div_eq_0_iff div_mult2_eq gr_implies_not0 mult_not_zero)

lemma in_square_lemma'[intro, simp]: "i < L \<Longrightarrow> n < N \<Longrightarrow> i * N + n < N * L" for i n::nat
  by (metis in_square_lemma mult.commute)

lemma
  distinct_nth_eq_iff:
  "distinct xs \<Longrightarrow> x < length xs \<Longrightarrow> y < length xs \<Longrightarrow> xs ! x = xs ! y \<longleftrightarrow> x = y"
  by (drule inj_on_nth[where I="{..<length xs}"]) (auto simp: inj_onD)

lemma index_Basis_list_axis2:
  "index Basis_list (axis (j::'j::enum) (axis (i::'i::enum) (1::real))) =
    (index enum_class.enum j) * CARD('i) + index enum_class.enum i"
  apply (auto simp: Basis_list_vec_def Basis_list_real_def o_def)
  apply (subst concat_map_map_index)
  unfolding card_UNIV_length_enum[symmetric]
  subgoal
  proof -
    have index_less_cardi: "index enum_class.enum k < CARD('i)" for k::'i
      by (rule index_less) (auto simp: enum_UNIV card_UNIV_length_enum)
    have index_less_cardj: "index enum_class.enum k < CARD('j)" for k::'j
      by (rule index_less) (auto simp: enum_UNIV card_UNIV_length_enum)
    have *: "axis j (axis i 1) =
      (\<lambda>i. axis (enum_class.enum ! (i div CARD('i)))
                      (axis (enum_class.enum ! (i mod CARD('i))) 1))
      ((index enum_class.enum j) * CARD('i) + index enum_class.enum i)"
      by (auto simp: index_less_cardi enum_UNIV)
    note less=in_square_lemma[OF index_less_cardj index_less_cardi, of j i]
    show ?thesis
      apply (subst *)
      apply (subst index_map_inj_on[where S="{..<CARD('j)*CARD('i)}"])
      subgoal
        apply (auto intro!: inj_onI simp: axis_eq_axis )
         apply (subst (asm) distinct_nth_eq_iff)
        apply (auto simp: enum_distinct card_UNIV_length_enum)
        subgoal for x y
          using gr_implies_not0 by fastforce
        subgoal for x y
          using gr_implies_not0 by fastforce
        subgoal for x y
          apply (drule inj_onD[OF inj_on_nth[OF enum_distinct[where 'a='j], where I = "{..<CARD('j)}"], rotated])
             apply (auto simp: card_UNIV_length_enum mult.commute)
          subgoal
            by (metis mod_mult_div_eq)
          done
        done
      subgoal using less by (auto simp: )
      subgoal by (auto simp: card_UNIV_length_enum ac_simps)
      subgoal apply (subst index_upt)
        subgoal using less by auto
        subgoal using less by (auto simp: ac_simps)
        subgoal using less by auto
        done
      done
  qed
  done

lemma
  vec_nth_Basis2:
  fixes x::"real^'n^'m"
  shows "x \<in> Basis \<Longrightarrow> vec_nth (vec_nth x i) j = ((if x = axis i (axis j 1) then 1 else 0))"
  by (auto simp: Basis_vec_def axis_def)

lemma vec_nth_eucl_of_list_eq2: "length M = CARD('n) * CARD('m) \<Longrightarrow>
  vec_nth (vec_nth (eucl_of_list M::real^'n::enum^'m::enum) i) j = M ! index Basis_list (axis i (axis j (1::real)))"
  apply (auto simp: eucl_of_list_def)
  apply (subst sum_list_zip_map_of)
   apply (auto intro!: distinct_zipI2 simp: split_beta')
  apply (subst sum.cong[OF refl])
   apply (subst vec_nth_Basis2)
    apply (force simp: set_zip)
  apply (rule refl)
  apply (auto simp: if_distrib sum.delta cong: if_cong)
  subgoal
    apply (cases "map_of (zip Basis_list M) (axis i (axis j 1)::real^'n::enum^'m::enum)")
    subgoal premises prems
    proof -
      have "fst ` set (zip Basis_list M) = (Basis::(real^'n::enum^'m::enum) set)" using prems
        by (auto simp: in_set_zip)
      then show ?thesis
        using prems
        by (subst (asm) map_of_eq_None_iff) auto
    qed
    subgoal for a
      apply (auto simp: in_set_zip)
      subgoal premises prems for n
      proof -
        have "n < card (Basis::(real^'n::_^'m::_) set)"
          by (simp add: prems(4))
        then show ?thesis
          by (metis index_Basis_list_nth prems(2))
      qed
      done
    done
  done

lemma vec_nth_eq_list_of_eucl2:
  "vec_nth (vec_nth (M::real^'n::enum^'m::enum) i) j =
    list_of_eucl M ! (index enum_class.enum i * CARD('n) + index enum_class.enum j)"
  apply (subst eucl_of_list_list_of_eucl[of M, symmetric])
  apply (subst vec_nth_eucl_of_list_eq2)
  unfolding index_Basis_list_axis2
  by auto

theorem
  eucl_of_list_matrix_vector_mult_eq_sum_nth_Basis_list:
  assumes "length M = CARD('n) * CARD('m)"
  assumes "length v = CARD('n)"
  shows "(eucl_of_list M::real^'n::enum^'m::enum) *v eucl_of_list v =
    (\<Sum>i<CARD('m).
      (\<Sum>j<CARD('n). M ! (i * CARD('n) + j) * v ! j) *\<^sub>R Basis_list ! i)"
  apply (vector matrix_vector_mult_def)
  apply (auto simp: )
  apply (subst vec_nth_eucl_of_list_eq2)
   apply (auto simp: assms)
  apply (subst vec_nth_eucl_of_list_eq)
   apply (auto simp: assms index_Basis_list_axis2 index_Basis_list_axis1 vec_nth_Basis sum.delta
      nth_eq_iff_index
      if_distrib cong: if_cong)
  subgoal for i
    apply (rule sum.reindex_cong[where l="nth enum_class.enum"])
      apply (auto simp: enum_distinct card_UNIV_length_enum distinct_nth_eq_iff intro!: inj_onI)
     apply (rule image_eqI[OF ])
      apply (rule nth_index[symmetric])
      apply (auto simp: enum_UNIV)
    by (auto simp: algebra_simps enum_UNIV enum_distinct index_nth_id)
  subgoal for i
    using index_less[of i "enum_class.enum" "CARD('n)"]
    by (auto simp: enum_UNIV card_UNIV_length_enum)
  done

lemma index_enum_less[intro, simp]: "index enum_class.enum (i::'n::enum) < CARD('n)"
  by (auto intro!: index_less simp: enum_UNIV card_UNIV_length_enum)

lemmas [intro, simp] = enum_distinct
lemmas [simp] = card_UNIV_length_enum[symmetric] enum_UNIV

lemma sum_index_enum_eq:
  "(\<Sum>(k::'n::enum)\<in>UNIV. f (index enum_class.enum k)) = (\<Sum>i<CARD('n). f i)"
  by (rule sum.reindex_cong[where l="nth enum_class.enum"])
    (force intro!: inj_onI simp: distinct_nth_eq_iff index_nth_id)+

end


theory Exe4p1
  imports Main
begin

lemma assumes T: "\<forall>x y. T x y \<or> T y x"
  and A: "\<forall>x y. A x y \<and> A y x \<longrightarrow> x = y"
  and TA: "\<forall>x y. T x y \<longrightarrow> A x y" and "A x y"
shows "T x y"
proof (rule ccontr)
  assume "\<not>T x y"
  hence "T y x" using T by blast
  hence "A y x" using TA by blast
  hence "x = y" using A and `A x y` by blast
  thus False using `T y x` and `\<not>T x y` by blast
qed


theory Ex040
  imports Main
begin

lemma "(A \<longrightarrow> B) \<or> (B \<longrightarrow> A)"
proof -
  {
    assume "\<not>((A \<longrightarrow> B) \<or> (B \<longrightarrow> A))"
    {
      assume "\<not>(A \<longrightarrow> B)"
      {
        assume B
        {
          assume A
          from \<open>B\<close> have B by assumption
        }
        hence "A \<longrightarrow> B" by (rule impI)
        with \<open>\<not>(A \<longrightarrow> B)\<close> have False by contradiction
        hence A by (rule FalseE)
      }
      hence "B \<longrightarrow> A" by (rule impI)
      hence "(A \<longrightarrow> B) \<or> (B \<longrightarrow> A)" by (rule disjI2)
      with \<open>\<not>((A \<longrightarrow> B) \<or> (B \<longrightarrow> A))\<close> have False by contradiction
    }
    hence "\<not>\<not>(A \<longrightarrow> B)" by (rule notI)
    hence "A \<longrightarrow> B" by (rule notnotD)
    hence "(A \<longrightarrow> B) \<or> (B \<longrightarrow> A)" by (rule disjI1)
    with \<open>\<not>((A \<longrightarrow> B) \<or> (B \<longrightarrow> A))\<close> have False by contradiction
  }
  hence "\<not>\<not>((A \<longrightarrow> B) \<or> (B \<longrightarrow> A))" by (rule notI)
  thus "(A \<longrightarrow> B) \<or> (B \<longrightarrow> A)" by (rule notnotD)
qed


theory T170
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


(* 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.*)
  theory TIP_prop_69
  imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun t22 :: "Nat => Nat => Nat" where
  "t22 (Z) y = y"
| "t22 (S z) y = S (t22 z y)"

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

theorem property0 :
  "t2 n (t22 m n)"
  oops

end


(* Author: Florian Haftmann, TU Muenchen *)

section \<open>A HOL random engine\<close>

theory Random
imports List Groups_List Code_Numeral
begin

subsection \<open>Auxiliary functions\<close>

fun log :: "natural \<Rightarrow> natural \<Rightarrow> natural" where
  "log b i = (if b \<le> 1 \<or> i < b then 1 else 1 + log b (i div b))"

definition inc_shift :: "natural \<Rightarrow> natural \<Rightarrow> natural" where
  "inc_shift v k = (if v = k then 1 else k + 1)"

definition minus_shift :: "natural \<Rightarrow> natural \<Rightarrow> natural \<Rightarrow> natural" where
  "minus_shift r k l = (if k < l then r + k - l else k - l)"

subsection \<open>Random seeds\<close>

type_synonym seed = "natural \<times> natural"

primrec "next" :: "seed \<Rightarrow> natural \<times> seed" where
  "next (v, w) = (let
     k =  v div 53668;
     v' = minus_shift 2147483563 ((v mod 53668) * 40014) (k * 12211);
     l =  w div 52774;
     w' = minus_shift 2147483399 ((w mod 52774) * 40692) (l * 3791);
     z =  minus_shift 2147483562 v' (w' + 1) + 1
   in (z, (v', w')))"

definition split_seed :: "seed \<Rightarrow> seed \<times> seed" where
  "split_seed s = (let
     (v, w) = s;
     (v', w') = snd (next s);
     v'' = inc_shift 2147483562 v;
     w'' = inc_shift 2147483398 w
   in ((v'', w'), (v', w'')))"

subsection \<open>Base selectors\<close>

context
  includes state_combinator_syntax
begin

fun iterate :: "natural \<Rightarrow> ('b \<Rightarrow> 'a \<Rightarrow> 'b \<times> 'a) \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'b \<times> 'a" where
  "iterate k f x = (if k = 0 then Pair x else f x \<circ>\<rightarrow> iterate (k - 1) f)"

definition range :: "natural \<Rightarrow> seed \<Rightarrow> natural \<times> seed" where
  "range k = iterate (log 2147483561 k)
      (\<lambda>l. next \<circ>\<rightarrow> (\<lambda>v. Pair (v + l * 2147483561))) 1
    \<circ>\<rightarrow> (\<lambda>v. Pair (v mod k))"

lemma range:
  "k > 0 \<Longrightarrow> fst (range k s) < k"
  by (simp add: range_def split_def less_natural_def del: log.simps iterate.simps)

definition select :: "'a list \<Rightarrow> seed \<Rightarrow> 'a \<times> seed" where
  "select xs = range (natural_of_nat (length xs))
    \<circ>\<rightarrow> (\<lambda>k. Pair (nth xs (nat_of_natural k)))"

lemma select:
  assumes "xs \<noteq> []"
  shows "fst (select xs s) \<in> set xs"
proof -
  from assms have "natural_of_nat (length xs) > 0" by (simp add: less_natural_def)
  with range have
    "fst (range (natural_of_nat (length xs)) s) < natural_of_nat (length xs)" by best
  then have
    "nat_of_natural (fst (range (natural_of_nat (length xs)) s)) < length xs" by (simp add: less_natural_def)
  then show ?thesis
    by (simp add: split_beta select_def)
qed

primrec pick :: "(natural \<times> 'a) list \<Rightarrow> natural \<Rightarrow> 'a" where
  "pick (x # xs) i = (if i < fst x then snd x else pick xs (i - fst x))"

lemma pick_member:
  "i < sum_list (map fst xs) \<Longrightarrow> pick xs i \<in> set (map snd xs)"
  by (induct xs arbitrary: i) (simp_all add: less_natural_def)

lemma pick_drop_zero:
  "pick (filter (\<lambda>(k, _). k > 0) xs) = pick xs"
  by (induct xs) (auto simp add: fun_eq_iff less_natural_def minus_natural_def)

lemma pick_same:
  "l < length xs \<Longrightarrow> Random.pick (map (Pair 1) xs) (natural_of_nat l) = nth xs l"
proof (induct xs arbitrary: l)
  case Nil then show ?case by simp
next
  case (Cons x xs) then show ?case by (cases l) (simp_all add: less_natural_def)
qed

definition select_weight :: "(natural \<times> 'a) list \<Rightarrow> seed \<Rightarrow> 'a \<times> seed" where
  "select_weight xs = range (sum_list (map fst xs))
   \<circ>\<rightarrow> (\<lambda>k. Pair (pick xs k))"

lemma select_weight_member:
  assumes "0 < sum_list (map fst xs)"
  shows "fst (select_weight xs s) \<in> set (map snd xs)"
proof -
  from range assms
    have "fst (range (sum_list (map fst xs)) s) < sum_list (map fst xs)" .
  with pick_member
    have "pick xs (fst (range (sum_list (map fst xs)) s)) \<in> set (map snd xs)" .
  then show ?thesis by (simp add: select_weight_def scomp_def split_def)
qed

lemma select_weight_cons_zero:
  "select_weight ((0, x) # xs) = select_weight xs"
  by (simp add: select_weight_def less_natural_def)

lemma select_weight_drop_zero:
  "select_weight (filter (\<lambda>(k, _). k > 0) xs) = select_weight xs"
proof -
  have "sum_list (map fst [(k, _)\<leftarrow>xs . 0 < k]) = sum_list (map fst xs)"
    by (induct xs) (auto simp add: less_natural_def natural_eq_iff)
  then show ?thesis by (simp only: select_weight_def pick_drop_zero)
qed

lemma select_weight_select:
  assumes "xs \<noteq> []"
  shows "select_weight (map (Pair 1) xs) = select xs"
proof -
  have less: "\<And>s. fst (range (natural_of_nat (length xs)) s) < natural_of_nat (length xs)"
    using assms by (intro range) (simp add: less_natural_def)
  moreover have "sum_list (map fst (map (Pair 1) xs)) = natural_of_nat (length xs)"
    by (induct xs) simp_all
  ultimately show ?thesis
    by (auto simp add: select_weight_def select_def scomp_def split_def
      fun_eq_iff pick_same [symmetric] less_natural_def)
qed

end

subsection \<open>\<open>ML\<close> interface\<close>

code_reflect Random_Engine
  functions range select select_weight

ML \<open>
structure Random_Engine =
struct

open Random_Engine;

type seed = Code_Numeral.natural * Code_Numeral.natural;

local

val seed = Unsynchronized.ref
  (let
    val now = Time.toMilliseconds (Time.now ());
    val (q, s1) = IntInf.divMod (now, 2147483562);
    val s2 = q mod 2147483398;
  in apply2 Code_Numeral.natural_of_integer (s1 + 1, s2 + 1) end);

in

fun next_seed () =
  let
    val (seed1, seed') = @{code split_seed} (! seed)
    val _ = seed := seed'
  in
    seed1
  end

fun run f =
  let
    val (x, seed') = f (! seed);
    val _ = seed := seed'
  in x end;

end;

end;
\<close>

hide_type (open) seed
hide_const (open) inc_shift minus_shift log "next" split_seed
  iterate range select pick select_weight
hide_fact (open) range_def

end


(* 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.
\:w
   Some proofs were added by Yutaka Nagashima.*)
  theory TIP_sort_BSortPermutes
  imports "../../Test_Base"
begin

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

fun x :: "'a list => 'a list => 'a list" where
  "x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun sort2 :: "int => int => int list" where
  "sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun pairs :: "int list => int list => int list" where
  "pairs (nil2) z = z"
| "pairs (cons2 z2 x2) (nil2) = cons2 z2 x2"
| "pairs (cons2 z2 x2) (cons2 x3 x4) =
     x (sort2 z2 x3) (pairs x2 x4)"

fun stitch :: "int list => int list => int list" where
  "stitch (nil2) z = z"
| "stitch (cons2 z2 xs) z = cons2 z2 (pairs xs z)"

function evens :: "'a list => 'a list"
  and odds :: "'a list => 'a list" where
  "evens (nil2) = nil2"
| "evens (cons2 z xs) = cons2 z (odds xs)"
| "odds (nil2) = nil2"
| "odds (cons2 z xs) = evens xs"
  by pat_completeness auto

fun elem :: "'a => 'a list => bool" where
  "elem y (nil2) = False"
| "elem y (cons2 z2 xs) = ((z2 = y) | (elem y xs))"

fun deleteBy :: "('a => ('a => bool)) => 'a => 'a list =>
                 'a list" where
  "deleteBy y z (nil2) = nil2"
| "deleteBy y z (cons2 y2 ys) =
     (if (y z) y2 then ys else cons2 y2 (deleteBy y z ys))"

fun isPermutation :: "'a list => 'a list => bool" where
  "isPermutation (nil2) (nil2) = True"
| "isPermutation (nil2) (cons2 z2 x2) = False"
| "isPermutation (cons2 x3 xs) z =
     ((elem x3 z) &
        (isPermutation
           xs (deleteBy (% (x4 :: 'a) => % (x5 :: 'a) => (x4 = x5)) x3 z)))"

(*fun did not finish the proof*)
function bmerge :: "int list => int list => int list" where
  "bmerge (nil2) z = nil2"
| "bmerge (cons2 z2 x2) (nil2) = cons2 z2 x2"
| "bmerge (cons2 z2 x2) (cons2 x3 x4) =
     (let fail :: int list =
       stitch
         (bmerge (evens (cons2 z2 x2)) (evens (cons2 x3 x4)))
         (bmerge (odds (cons2 z2 x2)) (odds (cons2 x3 x4)))
     in (case x2 of
           nil2 =>
             (case x4 of
                nil2 => sort2 z2 x3
                | cons2 x5 x6 => fail)
           | cons2 x7 x8 => fail))"
  by pat_completeness auto

(*fun did not finish the proof*)
function bsort :: "int list => int list" where
  "bsort (nil2) = nil2"
| "bsort (cons2 z (nil2)) = cons2 z (nil2)"
| "bsort (cons2 z (cons2 x2 x3)) =
     bmerge
       (bsort (evens (cons2 z (cons2 x2 x3))))
       (bsort (odds (cons2 z (cons2 x2 x3))))"
  by pat_completeness auto

theorem property0 :
  "isPermutation (bsort xs) xs"
  oops

end


theory CoinductiveDY
imports Main
begin

datatype msg = Nonce nat
             | Tup msg msg
             | Enc msg msg

coinductive_set infer :: "msg set \<Rightarrow> msg set"
for M :: "msg set"
where
  Inj: "m \<in> M \<Longrightarrow> m \<in> infer M"
| Tup: "\<lbrakk> x \<in> infer M; y \<in> infer M \<rbrakk> \<Longrightarrow> Tup x y \<in> infer M"
| Enc: "\<lbrakk> m \<in> infer M; k \<in> infer M \<rbrakk> \<Longrightarrow> Enc m k \<in> infer M"
| Dec: "\<lbrakk> Enc m k \<in> infer M; k \<in> infer M \<rbrakk> \<Longrightarrow> m \<in> infer M"

lemma infer_empty [simp]: "x \<notin> infer {}"
proof
  show "x \<in> infer {} \<Longrightarrow> False"
    apply(erule infer.cases)
    apply(auto)

thm infer.coinduct

  proof(cases rule: infer.coinduct)


theory Bool1
  imports Main
begin

lemma "(P::bool) \<noteq> True \<Longrightarrow>P = False"
proof (induct P)
  case True
  then show ?case by simp
next
  case False
  then show ?case by simp
qed

lemma "P = True \<or> P = False"
proof (induct P)
  case True
  then show ?case by simp
next
  case False
  then show ?case by simp
qed


theory homework3
  imports "HOL-IMP.Hoare_Examples"
begin

inductive star :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"  for r where
  refl:  "star r x x"
| step:  "r x y \<Longrightarrow> star r y z \<Longrightarrow> star r x z"

(* Problem 1 *)

inductive palindrome :: "'a list \<Rightarrow> bool" where
  "palindrome []"  |
  "palindrome [x]" |
(* If xs is a palindrome, so is a#xs@[a]. *)
  "palindrome xs \<Longrightarrow> palindrome (x#xs@[x])"

lemma "palindrome xs \<Longrightarrow> rev xs = xs"
  apply(induction xs rule: palindrome.induct)
  apply(simp_all)
  done

(*qed*)

(* Problem 2 *)

inductive star' :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" for r where
  refl': "star' r x x"
| step': "star' r x y \<Longrightarrow> r y z \<Longrightarrow> star' r x z"

lemma star_step2 :"star r x y \<Longrightarrow> r y z \<Longrightarrow> star r x z"
  apply(induction rule: star.induct)
  by (auto intro: star.intros)

(* forward proof *)
lemma star_equal1 :"star' r x y \<Longrightarrow> star r x y"
  apply(induction rule: star'.induct)
  apply(rule star.refl)
  apply(simp add: star_step2)
  done

lemma star2_one: "r x y \<Longrightarrow> star' r x y"
  apply(rule star'.step')
  apply(rule star'.refl')
  apply auto
  done

lemma star2_step2: "star' r y z \<Longrightarrow> r x y \<Longrightarrow> star' r x z"
  apply(induction rule: star'.induct)
  apply(simp add: star2_one)
  apply(simp add: star'.step')
  done

(* backward proof *)
lemma "star r x y \<Longrightarrow> star' r x y"
  apply(induction rule: star.induct)
  apply(simp add: star'.refl')
  apply(simp add: star2_step2)
  done

(*qed*)

(* Problem 3 *)

lemma
  "\<turnstile> {\<lambda>s. s ''x'' = x \<and> s ''y'' = y \<and> 0 \<le> x}
     WHILE Less (N 0) (V ''x'') DO (
       ''x'' ::= Plus (V ''x'') (N (-1));;
       ''y'' ::= Plus (V ''y'') (N (-1))
     )
     {\<lambda>t. t ''y'' = y - x}"
  apply(rule strengthen_pre[where P="\<lambda>s. s ''y'' = y - (x - s ''x'') \<and> s ''x'' \<ge> 0 \<and> 0 \<le> x"])
   apply(simp)
  apply(rule While')
   prefer 2
   apply(simp)
  apply(rule Seq)
   prefer 2
   apply(rule Assign)
  apply(rule Assign')
  apply(simp)
  done
(*qed*)

(* Problem 4 *)

lemma
  "\<turnstile> { \<lambda>s. s ''x'' = i \<and> 0 \<le> i}
     ''r'' ::= N 0;; ''r2'' ::= N 1;;
     WHILE (Not (Less (V ''x'') (V ''r2'')))
     DO (''r'' ::= Plus (V ''r'') (N 1);;
            ''r2'' ::= Plus (V ''r2'') (Plus (Plus (V ''r'') (V ''r'')) (N 1)))
     {\<lambda>s. (s ''r'')^2 \<le> i \<and> i < (s ''r'' + 1)^2}"
  apply(rule Seq)
   prefer 2
  apply(rule While'[where P= "\<lambda>s. s ''x'' = i \<and> (s ''r'')^2 \<le> i \<and> s ''r2'' = ((s ''r'') + 1)^2 \<and> 0 \<le> (s ''r'')"])
    apply(rule Seq)
     prefer 2
     apply(rule Assign)
    apply(simp add: power2_eq_square algebra_simps)
    apply(rule Assign')
    apply(simp add: algebra_simps)
   apply(simp)
  apply(rule Seq)
   prefer 2
   apply(rule Assign)
  apply(simp)
  apply(rule Assign')
  apply(auto)
  done

(*qed*)
end


(*  Title:      ZF/Induct/Binary_Trees.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1992  University of Cambridge
*)

section \<open>Binary trees\<close>

theory Binary_Trees imports ZF begin

subsection \<open>Datatype definition\<close>

consts
  bt :: "i => i"

datatype "bt(A)" =
  Lf | Br ("a \<in> A", "t1 \<in> bt(A)", "t2 \<in> bt(A)")

declare bt.intros [simp]

lemma Br_neq_left: "l \<in> bt(A) ==> Br(x, l, r) \<noteq> l"
  by (induct arbitrary: x r set: bt) auto

lemma Br_iff: "Br(a, l, r) = Br(a', l', r') \<longleftrightarrow> a = a' & l = l' & r = r'"
  \<comment> \<open>Proving a freeness theorem.\<close>
  by (fast elim!: bt.free_elims)

inductive_cases BrE: "Br(a, l, r) \<in> bt(A)"
  \<comment> \<open>An elimination rule, for type-checking.\<close>

text \<open>
  \medskip Lemmas to justify using \<^term>\<open>bt\<close> in other recursive type
  definitions.
\<close>

lemma bt_mono: "A \<subseteq> B ==> bt(A) \<subseteq> bt(B)"
  apply (unfold bt.defs)
  apply (rule lfp_mono)
    apply (rule bt.bnd_mono)+
  apply (rule univ_mono basic_monos | assumption)+
  done

lemma bt_univ: "bt(univ(A)) \<subseteq> univ(A)"
  apply (unfold bt.defs bt.con_defs)
  apply (rule lfp_lowerbound)
   apply (rule_tac [2] A_subset_univ [THEN univ_mono])
  apply (fast intro!: zero_in_univ Inl_in_univ Inr_in_univ Pair_in_univ)
  done

lemma bt_subset_univ: "A \<subseteq> univ(B) ==> bt(A) \<subseteq> univ(B)"
  apply (rule subset_trans)
   apply (erule bt_mono)
  apply (rule bt_univ)
  done

lemma bt_rec_type:
  "[| t \<in> bt(A);
    c \<in> C(Lf);
    !!x y z r s. [| x \<in> A;  y \<in> bt(A);  z \<in> bt(A);  r \<in> C(y);  s \<in> C(z) |] ==>
    h(x, y, z, r, s) \<in> C(Br(x, y, z))
  |] ==> bt_rec(c, h, t) \<in> C(t)"
  \<comment> \<open>Type checking for recursor -- example only; not really needed.\<close>
  apply (induct_tac t)
   apply simp_all
  done

subsection \<open>Number of nodes, with an example of tail-recursion\<close>

consts  n_nodes :: "i => i"
primrec
  "n_nodes(Lf) = 0"
  "n_nodes(Br(a, l, r)) = succ(n_nodes(l) #+ n_nodes(r))"

lemma n_nodes_type [simp]: "t \<in> bt(A) ==> n_nodes(t) \<in> nat"
  by (induct set: bt) auto

consts  n_nodes_aux :: "i => i"
primrec
  "n_nodes_aux(Lf) = (\<lambda>k \<in> nat. k)"
  "n_nodes_aux(Br(a, l, r)) =
      (\<lambda>k \<in> nat. n_nodes_aux(r) `  (n_nodes_aux(l) ` succ(k)))"

lemma n_nodes_aux_eq:
    "t \<in> bt(A) ==> k \<in> nat ==> n_nodes_aux(t)`k = n_nodes(t) #+ k"
  apply (induct arbitrary: k set: bt)
   apply simp
  apply (atomize, simp)
  done

definition
  n_nodes_tail :: "i => i"  where
  "n_nodes_tail(t) == n_nodes_aux(t) ` 0"

lemma "t \<in> bt(A) ==> n_nodes_tail(t) = n_nodes(t)"
  by (simp add: n_nodes_tail_def n_nodes_aux_eq)

subsection \<open>Number of leaves\<close>

consts
  n_leaves :: "i => i"
primrec
  "n_leaves(Lf) = 1"
  "n_leaves(Br(a, l, r)) = n_leaves(l) #+ n_leaves(r)"

lemma n_leaves_type [simp]: "t \<in> bt(A) ==> n_leaves(t) \<in> nat"
  by (induct set: bt) auto

subsection \<open>Reflecting trees\<close>

consts
  bt_reflect :: "i => i"
primrec
  "bt_reflect(Lf) = Lf"
  "bt_reflect(Br(a, l, r)) = Br(a, bt_reflect(r), bt_reflect(l))"

lemma bt_reflect_type [simp]: "t \<in> bt(A) ==> bt_reflect(t) \<in> bt(A)"
  by (induct set: bt) auto

text \<open>
  \medskip Theorems about \<^term>\<open>n_leaves\<close>.
\<close>

lemma n_leaves_reflect: "t \<in> bt(A) ==> n_leaves(bt_reflect(t)) = n_leaves(t)"
  by (induct set: bt) (simp_all add: add_commute)

lemma n_leaves_nodes: "t \<in> bt(A) ==> n_leaves(t) = succ(n_nodes(t))"
  by (induct set: bt) simp_all

text \<open>
  Theorems about \<^term>\<open>bt_reflect\<close>.
\<close>

lemma bt_reflect_bt_reflect_ident: "t \<in> bt(A) ==> bt_reflect(bt_reflect(t)) = t"
  by (induct set: bt) simp_all

end


theory VeggieBurger
  imports ConceptsAsModalitiesDL
begin

consts burger :: concept
consts meat   :: concept
consts bread  :: concept
consts veggie  :: concept
consts Ingredient :: relation
consts a :: i

axiomatization where
  (* TBox *)
  T1: "burger \<sqsubseteq> (\<^bold>\<exists>Ingredient. meat)" and
  T2: "burger \<sqsubseteq> (\<^bold>\<exists>Ingredient. bread)" and
  T3: "veggie \<sqsubseteq> (\<^bold>\<forall>Ingredient. veggie)" and
  T4: "\<bottom>     \<equiv>  veggie \<sqinter> meat" and
  T5: "veggie \<midarrow>\<circ> bread \<sqsubseteq> bread" and
  (* ABox *)
  A1: "a \<^bold>: veggie \<midarrow>\<circ> burger"

theorem "a \<^bold>: (\<^bold>\<exists>Ingredient. veggie \<midarrow>\<circ> meat)"
proof -
  from A1 have "a \<^bold>: veggie \<midarrow>\<circ> burger" by -
  hence "\<exists>v2. (veggie \<midarrow>\<circ> burger)(a,vn,v2)" by -
  hence "\<exists>v2. \<exists>v1. veggie(a,vn,v1) \<and> burger(a,v1,v2)" by simp
  hence "\<exists>v2. \<exists>v1. veggie(a,vn,v1) \<and> (\<^bold>\<exists>Ingredient. meat)(a,v1,v2)"
    using T1 by blast
  hence "\<exists>v2. \<exists>v1. veggie(a,vn,v1) \<and> (\<exists>y. Ingredient(a,y) \<and> meat(y,v1,v2))"
    by simp
  hence "\<exists>y. Ingredient(a,y) \<and> (\<exists>v1. veggie(a,vn,v1) \<and> (\<exists>v2. meat(y,v1,v2)))"
    by auto
  moreover have "\<forall>y. (\<exists>v. veggie(a,vn,v)) \<and> Ingredient(a,y) \<longrightarrow> (\<exists>v. veggie(y,vn,v))"
    using T3 by blast
  ultimately have "\<exists>y. Ingredient(a,y) \<and> (\<exists>v1. veggie(y,vn,v1) \<and> (\<exists>v2. meat(y,v1,v2)))"
    using ConceptAx by blast
  hence "\<exists>y. Ingredient(a,y) \<and> (\<exists>v2. (veggie\<midarrow>\<circ>meat)(y,vn,v2))" by blast
  hence "\<exists>v2. (\<^bold>\<exists>Ingredient. veggie \<midarrow>\<circ> meat)(a,vn,v2)" by blast
  then show "a \<^bold>: (\<^bold>\<exists>Ingredient. veggie \<midarrow>\<circ> meat)" by -
qed

end


theory "C-Meet"
imports C "HOLCF-Meet"
begin

instantiation C :: Finite_Meet_cpo begin
  fixrec C_meet :: "C \<rightarrow> C \<rightarrow> C"
    where "C_meet\<cdot>(C\<cdot>a)\<cdot>(C\<cdot>b) = C\<cdot>(C_meet\<cdot>a\<cdot>b)"

  instance
  apply default
  proof(intro exI conjI strip)
    fix x y
    {
      fix t
      have "(t \<sqsubseteq> C_meet\<cdot>x\<cdot>y) = (t \<sqsubseteq> x \<and> t \<sqsubseteq> y)"
      proof (induct t rule:C.take_induct)
        fix n
        show "(C_take n\<cdot>t \<sqsubseteq> C_meet\<cdot>x\<cdot>y) = (C_take n\<cdot>t \<sqsubseteq> x \<and> C_take n\<cdot>t \<sqsubseteq> y)"
        proof (induct n arbitrary: t x y rule:nat_induct)
          case 0 thus ?case by auto
          next
          case (Suc n t x y)
            with C.nchotomy[of t] C.nchotomy[of x] C.nchotomy[of y]
            show ?case by fastforce
        qed
     qed auto
    } note * = this
    show "C_meet\<cdot>x\<cdot>y \<sqsubseteq> x" using * by auto
    show "C_meet\<cdot>x\<cdot>y \<sqsubseteq> y" using * by auto
    fix z
    assume "z \<sqsubseteq> x" and "z \<sqsubseteq> y"
    thus "z \<sqsubseteq> C_meet\<cdot>x\<cdot>y" using * by auto
qed
end

lemma C_meet_is_meet: "(z \<sqsubseteq> C_meet\<cdot>x\<cdot>y) = (z \<sqsubseteq> x \<and> z \<sqsubseteq> y)"
proof (induct z rule:C.take_induct)
  fix n
  show "(C_take n\<cdot>z \<sqsubseteq> C_meet\<cdot>x\<cdot>y) = (C_take n\<cdot>z \<sqsubseteq> x \<and> C_take n\<cdot>z \<sqsubseteq> y)"
  proof (induct n arbitrary: z x y rule:nat_induct)
    case 0 thus ?case by auto
    next
    case (Suc n z x y) thus ?case
      apply -
      apply (cases z, simp)
      apply (cases x, simp)
      apply (cases y, simp)
      apply (fastforce simp add: cfun_below_iff)
      done
  qed
qed auto

instance C :: cont_binary_meet
proof
  have [simp]:"\<And> x y. x \<sqinter> y = C_meet\<cdot>x\<cdot>y"
    using C_meet_is_meet
    by (blast intro: is_meetI)
  case goal1 thus ?case
    by (simp add: ch2ch_Rep_cfunR contlub_cfun_arg contlub_cfun_fun)
qed

lemma [simp]: "r \<sqinter> C\<cdot>r = r"
  by (auto intro: is_meetI simp add: below_C)

lemma [simp]: "(r \<sqinter> Cpred\<cdot>r) = Cpred \<cdot> r"
  by (metis Cpred_below below_refl is_meetI)

lemma [simp]: "(Cpred\<cdot>r \<sqinter> r) = Cpred \<cdot> r"
  by (metis Cpred_below below_refl is_meetI)

lemma [simp]: "C\<cdot>r \<sqinter> C\<cdot>r' = C\<cdot>(r \<sqinter> r')"
  apply (rule is_meetI)
  apply (metis below_refl meet_below1 monofun_cfun_arg)
  apply (metis below_refl meet_below2 monofun_cfun_arg)
  apply (case_tac a)
  apply auto
  by (metis meet_above_iff)

end


(*<*)
theory Containers_BNFs
  imports "HOL-Cardinals.Cardinals"
begin

(*
This theory has been tested with Isabelle2018.
It is best explored interactively by starting Isabelle/jEdit.

To download Isabelle2018 please visit

https://isabelle.in.tum.de/website-Isabelle2018/index.html

and follow the installation instruction from there.
*)

declare [[bnf_internals]]

unbundle lifting_syntax
(*>*)

section \<open>Containers are BNFs\<close>

typedecl S \<comment> \<open>A type/set of shapes.\<close>
typedecl U \<comment> \<open>A type/set of positions. Not present in the container
   formulation as they work directly with the dependent type P s
   for a fixed shape s. It can be thought of as the dependent sum
   type U = (Sum s : S. P s)\<close>

consts P :: "S \<Rightarrow> U set" \<comment> \<open>The actual assignments of positions to shapes.\<close>

text \<open>
The following type 'a F is the extension of a container.

We emulate the dependent sum type used in the containers paper using a subtype
of the independent product type. @{term "Func A B"} denotes the set of functions
from A to B. Since HOL functions are total any @{term "f \<in> Func A B"} is restricted
to return some fixed unspecified value outside of the domain @{term A}:
@{term "\<forall>x. x \<notin> A \<longrightarrow> f x = undefined"}. @{term "UNIV :: 'a set"} is the set of all
elements of type @{typ 'a}. In HOL it is necessarily non-empty.
\<close>

typedef (overloaded) 'a F = "{(s :: S, f). f \<in> Func (P s) (UNIV :: 'a set)}"
  by (auto simp: Func_def)

setup_lifting type_definition_F

text \<open>Forces a function to be @{term undefined} outside the given domain
(later this will be always @{term "P s"} for some fixed shape @{term s})\<close>

abbreviation restr where
  "restr A f x \<equiv> (if x \<in> A then f x else undefined)"

lift_definition map_F :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a F \<Rightarrow> 'b F" \<comment> \<open>Functorial action on the container extension.\<close>
  is "\<lambda>g (s, f). (s, restr (P s) (g o f))"
  by (auto simp: Func_def)

lift_definition set_F :: "'a F \<Rightarrow> 'a set" \<comment> \<open>The elemants contained in the container extension.\<close>
  is "\<lambda>(s, f). f ` P s" .

text \<open>The container extension is a BNF.\<close>

bnf "'a F"
  map: map_F
  sets: set_F
  bd: "natLeq +c card_of (UNIV :: U set)"
  subgoal by (rule ext, transfer) (auto simp: Func_def)
  subgoal by (rule ext, transfer) (auto simp: Func_def)
  subgoal by (transfer) (auto simp: Func_def)
  subgoal by (rule ext, transfer) (auto simp: Func_def)
  subgoal by (simp add: card_order_csum natLeq_card_order)
  subgoal by (simp add: cinfinite_csum natLeq_cinfinite)
  subgoal apply (transfer, clarsimp)
    apply (rule ordLeq_transitive[OF card_of_image])
    apply (rule ordLeq_transitive[OF _ ordLeq_csum2])
    apply simp_all
    done
  subgoal for R S
    apply (rule predicate2I, transfer fixing: R S, clarsimp simp: Func_def)
    subgoal for s f g
      by (rule exI[of _ "restr (P s) (\<lambda>u. (fst (f u), snd (g u)))"])
        (auto simp: relcompp_apply image_subset_iff split_beta fun_eq_iff split: if_splits)
    done
  done

text \<open>
The relator @{term rel_F} is defined internally in terms of @{term map_F} and @{term set_F}:
@{thm F.in_rel[no_vars]}.

Moreover, the above @{command bnf} command proves a wealth of useful BNF properties,
including the parametricity of most involved entities:
\begin{gather*}
@{thm F.map_transfer[no_vars]}\\
@{thm F.set_transfer[no_vars]}\\
@{thm F.rel_transfer[no_vars]}
\end{gather*}
\<close>

text \<open>The BNF structure arising from the container extension preserves pullbacks.

This proves that the BNF of finite sets (with image as the map function)
can not be obtained as a container extension, since for

R x y = True

z1 = \{(1,1), (2,2), (1,2)\}

z2 = \{(1,1), (2,2)\}

x = \{1, 2\}

y = \{1, 2\}

we obtain a contradiction to the below lemma.
\<close>

lemma unique_pullback:
  fixes z1 z2 x y
  assumes "set_F z1 \<subseteq> {(a,b). R a b}" "map_F fst z1 = x" "map_F snd z1 = y"
          "set_F z2 \<subseteq> {(a,b). R a b}" "map_F fst z2 = x" "map_F snd z2 = y"
  shows "z1 = z2"
  using assms unfolding subset_eq mem_Collect_eq split_beta Ball_def
  supply F.map_transfer[transfer_rule del] F.set_transfer[transfer_rule del]
  apply (transfer_start fixing: R) defer apply transfer_step+ defer apply (transfer_step, transfer_end)
  apply (auto simp: fun_eq_iff Func_def intro!: prod_eqI split: if_splits)
   apply metis+
  done

section \<open>Quotient Containers are BNFs\<close>

text \<open>Quotient Containers additionally allow to identify different elements
in the container extension that only differ by certain "allowed" permutations of positions.
G (for a shape s) is some set of allowed permutations (bijections) closed under composition
and inverses and containing identity.

The restriction of all functions to @{term "P s"} is necessary due to the lack of dependent types.
\<close>

axiomatization G where
  G_bij: "f \<in> G s \<Longrightarrow> bij_betw f (P s) (P s)" and
  G_id: "id \<in> G s" and
  G_comp: "f \<in> G s \<Longrightarrow> g \<in> G s \<Longrightarrow> restr (P s) (g o f) \<in> G s" and
  G_inv: "f \<in> G s \<Longrightarrow> restr (P s) (the_inv_into (P s) f) \<in> G s"

text \<open>The equivalence relation eq on the container extension
that allows to permute positions according to the functions in G.\<close>

lift_definition eq :: "'a F \<Rightarrow> 'a F \<Rightarrow> bool" is
  "\<lambda>(s1, f1). \<lambda>(s2, f2). s1 = s2 \<and> (\<exists>g \<in> G s1. f1 = restr (P s1) (f2 o g))" .

lemma eq_refl[simp]: "eq x x"
  by transfer (auto simp: fun_eq_iff Func_def G_id intro!: bexI[of _ id])

lemma eq_sym: "eq x y \<Longrightarrow> eq y x"
  apply (transfer; clarsimp)
  subgoal for s f1 f2
    apply (frule G_bij)
    apply (auto simp: fun_eq_iff Func_def G_inv
      f_the_inv_into_f_bij_betw bij_betw_def the_inv_into_into
      intro!: bexI[of _ "restr (P s) (the_inv_into (P s) f2)"])
    done
  done

lemma eq_trans: "eq x y \<Longrightarrow> eq y z \<Longrightarrow> eq x z"
  apply (transfer; clarsimp)
  subgoal for s f1 f g
    apply (frule G_bij)
    apply (auto simp: fun_eq_iff Func_def G_comp
      f_the_inv_into_f_bij_betw bij_betw_def the_inv_into_into
      intro!: bexI[of _ "restr (P s) (g o f)"])
    done
  done

text \<open>The extension of a quotient container is the container extension
  @{typ "'a F"}, quotiented by @{term eq}\<close>

quotient_type (overloaded) 'a Q = "'a F" / eq
  by (intro equivpI reflpI sympI transpI eq_refl | elim eq_sym eq_trans | assumption)+

lift_definition map_Q :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a Q \<Rightarrow> 'b Q" \<comment> \<open>Functorial action on the quotient container
    extension simply lifted from the container extension.\<close>
  is "map_F"
  subgoal for g f1 f2
    supply F.map_transfer[transfer_rule del]
    apply (transfer fixing: g, clarsimp)
    subgoal for s f1 f2
      apply (frule G_bij)
      apply (auto simp: fun_eq_iff Func_def bij_betw_def intro!: bexI[of _ f2])
      done
    done
  done

lift_definition set_Q :: "'a Q \<Rightarrow> 'a set" \<comment> \<open>The set of elements in the quotient container
    extension are the ones in the underlying container extension (equivalent container extension
    elements have equal sets of elements).\<close>
  is set_F
  subgoal for f1 f2
    supply F.set_transfer[transfer_rule del]
    apply (transfer, clarsimp)
    subgoal for s g f
    apply (frule G_bij)
      apply (auto simp: Func_def image_iff bij_betw_def intro: bexI[of _ "f _"])
      apply (metis image_iff)
      done
    done
  done

text \<open>The quotient container extension is a BNF.\<close>

bnf "'a Q"
  map: map_Q
  sets: set_Q
  bd: "natLeq +c card_of (UNIV :: U set)"
  subgoal by (rule ext, transfer) (auto simp: F.map_id)
  subgoal by (rule ext, transfer) (auto simp: F.map_comp)
  subgoal by (transfer) (auto cong: F.map_cong)
  subgoal by (rule ext, transfer) (auto simp: F.set_map)
  subgoal by (simp add: card_order_csum natLeq_card_order)
  subgoal by (simp add: cinfinite_csum natLeq_cinfinite)
  subgoal by (transfer, clarsimp, rule F.set_bd)
  subgoal for R S
    apply (rule predicate2I, transfer fixing: R S, clarsimp simp: Func_def)
    supply F.map_transfer[transfer_rule del] F.set_transfer[transfer_rule del]
    apply (transfer fixing: R S; clarsimp)
    subgoal for f1 s f2 f3 l r g1 g2 g3 g4
      apply (rule exI[of _ "restr (P s) (\<lambda>u. (fst (l u), snd (r (the_inv_into (P s) g3 (g2 u)))))"])
      apply (auto simp: relcompp_apply image_subset_iff split_beta fun_eq_iff Func_def
        split: if_splits)
       apply (smt G_bij bij_betw_def f_the_inv_into_f image_eqI the_inv_into_onto)
      apply (rule bexI[of _ "restr (P s) (g4 o restr (P s) (restr (P s) (the_inv_into (P s) g3) o g2))"], clarsimp)
      apply (metis G_bij bij_betw_def image_eqI the_inv_into_onto)
      apply (intro G_comp G_inv; assumption)
      done
    done
  done

text \<open>
As before relator @{term rel_Q} is defined internally in terms of @{term map_Q} and @{term set_Q}:
@{thm Q.in_rel[no_vars]}.

Moreover, the above @{command bnf} command proves a wealth of useful BNF properties,
including the parametricity of most involved entities:
\begin{gather*}
@{thm Q.map_transfer[no_vars]}\\
@{thm Q.set_transfer[no_vars]}\\
@{thm Q.rel_transfer[no_vars]}
\end{gather*}
\<close>

(*<*)
end
(*>*)