(*  Author:     Bernhard Haeupler

Proving equalities in commutative rings done "right" in Isabelle/HOL.
*)

section \<open>Proving equalities in commutative rings\<close>

theory Commutative_Ring
imports Main
begin

text \<open>Syntax of multivariate polynomials (pol) and polynomial expressions.\<close>

datatype 'a pol =
    Pc 'a
  | Pinj nat "'a pol"
  | PX "'a pol" nat "'a pol"

datatype 'a polex =
    Pol "'a pol"
  | Add "'a polex" "'a polex"
  | Sub "'a polex" "'a polex"
  | Mul "'a polex" "'a polex"
  | Pow "'a polex" nat
  | Neg "'a polex"

text \<open>Interpretation functions for the shadow syntax.\<close>

primrec Ipol :: "'a::comm_ring_1 list \<Rightarrow> 'a pol \<Rightarrow> 'a"
where
    "Ipol l (Pc c) = c"
  | "Ipol l (Pinj i P) = Ipol (drop i l) P"
  | "Ipol l (PX P x Q) = Ipol l P * (hd l)^x + Ipol (drop 1 l) Q"

primrec Ipolex :: "'a::comm_ring_1 list \<Rightarrow> 'a polex \<Rightarrow> 'a"
where
    "Ipolex l (Pol P) = Ipol l P"
  | "Ipolex l (Add P Q) = Ipolex l P + Ipolex l Q"
  | "Ipolex l (Sub P Q) = Ipolex l P - Ipolex l Q"
  | "Ipolex l (Mul P Q) = Ipolex l P * Ipolex l Q"
  | "Ipolex l (Pow p n) = Ipolex l p ^ n"
  | "Ipolex l (Neg P) = - Ipolex l P"

text \<open>Create polynomial normalized polynomials given normalized inputs.\<close>

definition mkPinj :: "nat \<Rightarrow> 'a pol \<Rightarrow> 'a pol"
where
  "mkPinj x P =
    (case P of
      Pc c \<Rightarrow> Pc c
    | Pinj y P \<Rightarrow> Pinj (x + y) P
    | PX p1 y p2 \<Rightarrow> Pinj x P)"

definition mkPX :: "'a::comm_ring pol \<Rightarrow> nat \<Rightarrow> 'a pol \<Rightarrow> 'a pol"
where
  "mkPX P i Q =
    (case P of
      Pc c \<Rightarrow> if c = 0 then mkPinj 1 Q else PX P i Q
    | Pinj j R \<Rightarrow> PX P i Q
    | PX P2 i2 Q2 \<Rightarrow> if Q2 = Pc 0 then PX P2 (i + i2) Q else PX P i Q)"

text \<open>Defining the basic ring operations on normalized polynomials\<close>

lemma pol_size_nz[simp]: "size (p :: 'a pol) \<noteq> 0"
  by (cases p) simp_all

function add :: "'a::comm_ring pol \<Rightarrow> 'a pol \<Rightarrow> 'a pol"  (infixl "\<oplus>" 65)
where
  "Pc a \<oplus> Pc b = Pc (a + b)"
| "Pc c \<oplus> Pinj i P = Pinj i (P \<oplus> Pc c)"
| "Pinj i P \<oplus> Pc c = Pinj i (P \<oplus> Pc c)"
| "Pc c \<oplus> PX P i Q = PX P i (Q \<oplus> Pc c)"
| "PX P i Q \<oplus> Pc c = PX P i (Q \<oplus> Pc c)"
| "Pinj x P \<oplus> Pinj y Q =
    (if x = y then mkPinj x (P \<oplus> Q)
     else (if x > y then mkPinj y (Pinj (x - y) P \<oplus> Q)
       else mkPinj x (Pinj (y - x) Q \<oplus> P)))"
| "Pinj x P \<oplus> PX Q y R =
    (if x = 0 then P \<oplus> PX Q y R
     else (if x = 1 then PX Q y (R \<oplus> P)
       else PX Q y (R \<oplus> Pinj (x - 1) P)))"
| "PX P x R \<oplus> Pinj y Q =
    (if y = 0 then PX P x R \<oplus> Q
     else (if y = 1 then PX P x (R \<oplus> Q)
       else PX P x (R \<oplus> Pinj (y - 1) Q)))"
| "PX P1 x P2 \<oplus> PX Q1 y Q2 =
    (if x = y then mkPX (P1 \<oplus> Q1) x (P2 \<oplus> Q2)
     else (if x > y then mkPX (PX P1 (x - y) (Pc 0) \<oplus> Q1) y (P2 \<oplus> Q2)
       else mkPX (PX Q1 (y-x) (Pc 0) \<oplus> P1) x (P2 \<oplus> Q2)))"
by pat_completeness auto
termination by (relation "measure (\<lambda>(x, y). size x + size y)") auto

function mul :: "'a::comm_ring pol \<Rightarrow> 'a pol \<Rightarrow> 'a pol"  (infixl "\<otimes>" 70)
where
  "Pc a \<otimes> Pc b = Pc (a * b)"
| "Pc c \<otimes> Pinj i P =
    (if c = 0 then Pc 0 else mkPinj i (P \<otimes> Pc c))"
| "Pinj i P \<otimes> Pc c =
    (if c = 0 then Pc 0 else mkPinj i (P \<otimes> Pc c))"
| "Pc c \<otimes> PX P i Q =
    (if c = 0 then Pc 0 else mkPX (P \<otimes> Pc c) i (Q \<otimes> Pc c))"
| "PX P i Q \<otimes> Pc c =
    (if c = 0 then Pc 0 else mkPX (P \<otimes> Pc c) i (Q \<otimes> Pc c))"
| "Pinj x P \<otimes> Pinj y Q =
    (if x = y then mkPinj x (P \<otimes> Q)
     else
       (if x > y then mkPinj y (Pinj (x-y) P \<otimes> Q)
        else mkPinj x (Pinj (y - x) Q \<otimes> P)))"
| "Pinj x P \<otimes> PX Q y R =
    (if x = 0 then P \<otimes> PX Q y R
     else
       (if x = 1 then mkPX (Pinj x P \<otimes> Q) y (R \<otimes> P)
        else mkPX (Pinj x P \<otimes> Q) y (R \<otimes> Pinj (x - 1) P)))"
| "PX P x R \<otimes> Pinj y Q =
    (if y = 0 then PX P x R \<otimes> Q
     else
       (if y = 1 then mkPX (Pinj y Q \<otimes> P) x (R \<otimes> Q)
        else mkPX (Pinj y Q \<otimes> P) x (R \<otimes> Pinj (y - 1) Q)))"
| "PX P1 x P2 \<otimes> PX Q1 y Q2 =
    mkPX (P1 \<otimes> Q1) (x + y) (P2 \<otimes> Q2) \<oplus>
      (mkPX (P1 \<otimes> mkPinj 1 Q2) x (Pc 0) \<oplus>
        (mkPX (Q1 \<otimes> mkPinj 1 P2) y (Pc 0)))"
by pat_completeness auto
termination by (relation "measure (\<lambda>(x, y). size x + size y)")
  (auto simp add: mkPinj_def split: pol.split)

text \<open>Negation\<close>
primrec neg :: "'a::comm_ring pol \<Rightarrow> 'a pol"
where
  "neg (Pc c) = Pc (-c)"
| "neg (Pinj i P) = Pinj i (neg P)"
| "neg (PX P x Q) = PX (neg P) x (neg Q)"

text \<open>Substraction\<close>
definition sub :: "'a::comm_ring pol \<Rightarrow> 'a pol \<Rightarrow> 'a pol"  (infixl "\<ominus>" 65)
  where "sub P Q = P \<oplus> neg Q"

text \<open>Square for Fast Exponentation\<close>
primrec sqr :: "'a::comm_ring_1 pol \<Rightarrow> 'a pol"
where
  "sqr (Pc c) = Pc (c * c)"
| "sqr (Pinj i P) = mkPinj i (sqr P)"
| "sqr (PX A x B) =
    mkPX (sqr A) (x + x) (sqr B) \<oplus> mkPX (Pc (1 + 1) \<otimes> A \<otimes> mkPinj 1 B) x (Pc 0)"

text \<open>Fast Exponentation\<close>

fun pow :: "nat \<Rightarrow> 'a::comm_ring_1 pol \<Rightarrow> 'a pol"
where
  pow_if [simp del]: "pow n P =
   (if n = 0 then Pc 1
    else if even n then pow (n div 2) (sqr P)
    else P \<otimes> pow (n div 2) (sqr P))"

lemma pow_simps [simp]:
  "pow 0 P = Pc 1"
  "pow (2 * n) P = pow n (sqr P)"
  "pow (Suc (2 * n)) P = P \<otimes> pow n (sqr P)"
  by (simp_all add: pow_if)

lemma even_pow: "even n \<Longrightarrow> pow n P = pow (n div 2) (sqr P)"
  by (erule evenE) simp

lemma odd_pow: "odd n \<Longrightarrow> pow n P = P \<otimes> pow (n div 2) (sqr P)"
  by (erule oddE) simp

text \<open>Normalization of polynomial expressions\<close>

primrec norm :: "'a::comm_ring_1 polex \<Rightarrow> 'a pol"
where
  "norm (Pol P) = P"
| "norm (Add P Q) = norm P \<oplus> norm Q"
| "norm (Sub P Q) = norm P \<ominus> norm Q"
| "norm (Mul P Q) = norm P \<otimes> norm Q"
| "norm (Pow P n) = pow n (norm P)"
| "norm (Neg P) = neg (norm P)"

text \<open>mkPinj preserve semantics\<close>
lemma mkPinj_ci: "Ipol l (mkPinj a B) = Ipol l (Pinj a B)"
  by (induct B) (auto simp add: mkPinj_def algebra_simps)

text \<open>mkPX preserves semantics\<close>
lemma mkPX_ci: "Ipol l (mkPX A b C) = Ipol l (PX A b C)"
  by (cases A) (auto simp add: mkPX_def mkPinj_ci power_add algebra_simps)

text \<open>Correctness theorems for the implemented operations\<close>

text \<open>Negation\<close>
lemma neg_ci: "Ipol l (neg P) = -(Ipol l P)"
  by (induct P arbitrary: l) auto

text \<open>Addition\<close>
lemma add_ci: "Ipol l (P \<oplus> Q) = Ipol l P + Ipol l Q"
proof (induct P Q arbitrary: l rule: add.induct)
  case (6 x P y Q)
  consider "x < y" | "x = y" | "x > y" by arith
  then
  show ?case
  proof cases
    case 1
    with 6 show ?thesis by (simp add: mkPinj_ci algebra_simps)
  next
    case 2
    with 6 show ?thesis by (simp add: mkPinj_ci)
  next
    case 3
    with 6 show ?thesis by (simp add: mkPinj_ci algebra_simps)
  qed
next
  case (7 x P Q y R)
  consider "x = 0" | "x = 1" | "x > 1" by arith
  then show ?case
  proof cases
    case 1
    with 7 show ?thesis by simp
  next
    case 2
    with 7 show ?thesis by (simp add: algebra_simps)
  next
    case 3
    from 7 show ?thesis by (cases x) simp_all
  qed
next
  case (8 P x R y Q)
  then show ?case by simp
next
  case (9 P1 x P2 Q1 y Q2)
  consider "x = y" | d where "d + x = y" | d where "d + y = x"
    by atomize_elim arith
  then show ?case
  proof cases
    case 1
    with 9 show ?thesis by (simp add: mkPX_ci algebra_simps)
  next
    case 2
    with 9 show ?thesis by (auto simp add: mkPX_ci power_add algebra_simps)
  next
    case 3
    with 9 show ?thesis by (auto simp add: power_add mkPX_ci algebra_simps)
  qed
qed (auto simp add: algebra_simps)

text \<open>Multiplication\<close>
lemma mul_ci: "Ipol l (P \<otimes> Q) = Ipol l P * Ipol l Q"
  by (induct P Q arbitrary: l rule: mul.induct)
    (simp_all add: mkPX_ci mkPinj_ci algebra_simps add_ci power_add)

text \<open>Substraction\<close>
lemma sub_ci: "Ipol l (P \<ominus> Q) = Ipol l P - Ipol l Q"
  by (simp add: add_ci neg_ci sub_def)

text \<open>Square\<close>
lemma sqr_ci: "Ipol ls (sqr P) = Ipol ls P * Ipol ls P"
  by (induct P arbitrary: ls)
    (simp_all add: add_ci mkPinj_ci mkPX_ci mul_ci algebra_simps power_add)

text \<open>Power\<close>
lemma pow_ci: "Ipol ls (pow n P) = Ipol ls P ^ n"
proof (induct n arbitrary: P rule: less_induct)
  case (less k)
  consider "k = 0" | "k > 0" by arith
  then
  show ?case
  proof cases
    case 1
    then show ?thesis by simp
  next
    case 2
    then have "k div 2 < k" by arith
    with less have *: "Ipol ls (pow (k div 2) (sqr P)) = Ipol ls (sqr P) ^ (k div 2)"
      by simp
    show ?thesis
    proof (cases "even k")
      case True
      with * show ?thesis
        by (simp add: even_pow sqr_ci power_mult_distrib power_add [symmetric]
          mult_2 [symmetric] even_two_times_div_two)
    next
      case False
      with * show ?thesis
        by (simp add: odd_pow mul_ci sqr_ci power_mult_distrib power_add [symmetric]
          mult_2 [symmetric] power_Suc [symmetric])
    qed
  qed
qed

text \<open>Normalization preserves semantics\<close>
lemma norm_ci: "Ipolex l Pe = Ipol l (norm Pe)"
  by (induct Pe) (simp_all add: add_ci sub_ci mul_ci neg_ci pow_ci)

text \<open>Reflection lemma: Key to the (incomplete) decision procedure\<close>
lemma norm_eq:
  assumes "norm P1 = norm P2"
  shows "Ipolex l P1 = Ipolex l P2"
proof -
  from assms have "Ipol l (norm P1) = Ipol l (norm P2)"
    by simp
  then show ?thesis
    by (simp only: norm_ci)
qed

ML_file "commutative_ring_tac.ML"

method_setup comm_ring = \<open>
  Scan.succeed (SIMPLE_METHOD' o Commutative_Ring_Tac.tac)
\<close> "reflective decision procedure for equalities over commutative rings"

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

datatype Nat = Z | S "Nat"

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

fun accaltmul :: "Nat => Nat => Nat" where
"accaltmul (Z) y = Z"
| "accaltmul (S z) (Z) = Z"
| "accaltmul (S z) (S x2) =
     accplus (S z) (accplus x2 (accaltmul z x2))"

theorem property0 :
  "((accaltmul x (accaltmul y z)) = (accaltmul (accaltmul x y) z))"
  oops

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_int_add_comm
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

datatype Integer = P "Nat" | N "Nat"

fun pred :: "Nat => Nat" where
"pred (S y) = y"

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

fun t2 :: "Nat => Nat => Integer" where
"t2 x y =
   (let fail :: Integer =
     (case y of
        Z => P x
        | S z =>
            (case x of
               Z => N y
               | S x2 => t2 x2 z))
   in (case x of
         Z =>
           (case y of
              Z => P Z
              | S x4 => fail)
         | S x3 => fail))"

fun plus :: "Integer => Integer => Integer" where
"plus (P m) (P n) = P (plus2 m n)"
| "plus (P m) (N o2) = t2 m (plus2 (S Z) o2)"
| "plus (N m2) (P n2) = t2 n2 (plus2 (S Z) m2)"
| "plus (N m2) (N n3) = N (plus2 (plus2 (S Z) m2) n3)"

theorem property0 :
  "((plus x y) = (plus y x))"
  oops

end


theory Lie_Groups_3
imports
  Main
  Smooth_Manifolds.Product_Manifold
  Smooth_Manifolds.Differentiable_Manifold
  Smooth_Manifolds.Tangent_Space
 (*
  Some code is freely adapted from Clemens Ballarin's A Case Study in Basic Algebra
  https://www.isa-afp.org/entries/Jacobson_Basic_Algebra.html
  *)

begin

section \<open>Monoids\<close>

locale monoid =
  fixes M and mult and unit ("\<one>")
  assumes mult_closed [intro, simp]: "\<lbrakk> a \<in> M; b \<in> M \<rbrakk> \<Longrightarrow> mult (a, b) \<in> M"
    and unit_closed [intro, simp]: "\<one> \<in> M"
    and assoc [intro]: "\<lbrakk> a \<in> M; b \<in> M; c \<in> M \<rbrakk> \<Longrightarrow> mult (mult (a, b), c) = mult (a, mult (b, c))"
    and l_unit [intro, simp]: "a \<in> M \<Longrightarrow> mult (\<one>, a) = a"
    and r_unit [intro, simp]: "a \<in> M \<Longrightarrow> mult (a, \<one>) = a"

begin

abbreviation multiplication (infixl "\<cdot>" 70) where
"multiplication a b \<equiv> mult (a, b)"

definition invertible where
"a \<in> M \<Longrightarrow> invertible a \<longleftrightarrow> (\<exists>b \<in> M. a \<cdot> b = \<one> \<and> b \<cdot> a = \<one>)"

end

locale submonoid = monoid +
  fixes N
  assumes subset [intro, simp]: "N \<subseteq> M"
    and sub_mult_closed: "\<lbrakk> a \<in> N; b \<in> N \<rbrakk> \<Longrightarrow> a \<cdot> b \<in> N"
    and sub_unit_closed: "\<one> \<in> N"

section \<open>Groups\<close>

locale group = monoid G mult unit for G and mult and unit ("\<one>") +
  fixes inv ("_\<^sup>-\<^sup>1")
  assumes l_inv: "a \<in> G \<Longrightarrow> (a\<^sup>-\<^sup>1) \<cdot> a = \<one>"
    and r_inv: "a \<in> G \<Longrightarrow> a \<cdot> (a\<^sup>-\<^sup>1) = \<one>"

locale subgroup = group +
  fixes H
  assumes subset [intro, simp]: "H \<subseteq> G"
    and sub_mult_closed: "\<lbrakk> a \<in> H; b \<in> H \<rbrakk> \<Longrightarrow> a \<cdot> b \<in> H"
    and sub_unit_closed: "\<one> \<in> H"
    and sub_inv_closed: "a \<in> H \<Longrightarrow> a\<^sup>-\<^sup>1 \<in> H"

subsection \<open>Subgroup Generated By a Subset\<close>

context group begin

inductive_set generate :: "'a set \<Rightarrow> 'a set"
  for H where
    unit:  "\<one> \<in> generate H"
  | incl: "a \<in> H \<Longrightarrow> a \<in> generate H"
  | inv:  "a \<in> H \<Longrightarrow> (a\<^sup>-\<^sup>1) \<in> generate H"
  | mult:  "a \<in> generate H \<Longrightarrow> b \<in> generate H \<Longrightarrow> a \<cdot> b \<in> generate H"

definition subgroup_generated :: "'a set \<Rightarrow> 'a set"
  where "subgroup_generated S = generate (G \<inter> S)"

lemma subgroup_generated_is_subgroup:
  fixes H
  shows "subgroup G mult unit inv (subgroup_generated H)" sorry

end (* group *)

subsection \<open>Right Cosets\<close>

context group begin

definition r_coset (infixl "|\<cdot>" 70) where "N |\<cdot> x = {h \<cdot> x | h. h \<in> N}"

end (* group *)

section \<open>Lie Groups\<close>

subsection \<open>Lie Groups\<close>

locale lie_group = c_manifold + is_group: group carrier mult unit inv for mult and unit and inv +
  assumes smooth_mult: "diff k (c_manifold_prod.prod_charts charts charts) charts mult"
    and smooth_inv: "diff k charts charts inv"

subsection \<open>Smooth Maps Between Lie Groups\<close>

locale lie_groups =
  src: lie_group charts1 k mult1 unit1 inv1 +
  dest: lie_group charts2 k mult2 unit2 inv2
  for k charts1 mult1 unit1 inv1 charts2 mult2 unit2 inv2

locale lie_diff = lie_groups k charts1 mult1 unit1 inv1 charts2 mult2 unit2 inv2
  for k
    and charts1 :: "('a::{t2_space,second_countable_topology}, 'e::euclidean_space) chart set"
    and mult1 unit1 inv1
    and charts2 :: "('b::{t2_space,second_countable_topology}, 'f::euclidean_space) chart set"
    and mult2 unit2 inv2
    +
  fixes f :: "('a \<Rightarrow> 'b)"
  assumes exists_smooth_on: "x \<in> src.carrier \<Longrightarrow>
    \<exists>c1\<in>src.atlas. \<exists>c2\<in>dest.atlas.
      x \<in> domain c1 \<and>
      f ` domain c1 \<subseteq> domain c2 \<and>
      k-smooth_on (codomain c1) (c2 \<circ> f \<circ> inv_chart c1)"

locale lie_diffeomorphism = lie_diff k charts1 mult1 unit1 inv1 charts2 mult2 unit2 inv2 f +
  inv: lie_diff k charts2 mult2 unit2 inv2 charts1 mult1 unit1 inv1 f'
  for k charts1 mult1 unit1 inv1 charts2 mult2 unit2 inv2 f f' +
  assumes f_inv[simp]:  "\<And>x. x \<in> src.carrier \<Longrightarrow> f' (f x) = x"
      and f'_inv[simp]: "\<And>y. y \<in> dest.carrier \<Longrightarrow> f (f' y) = y"

locale lie_group_map = lie_diffeomorphism k charts1 mult1 unit1 inv1 charts2 mult2 unit2 inv2 f f'
  for k charts1 mult1 unit1 inv1 charts2 mult2 unit2 inv2 f f' +
  assumes map_mult: "f (mult1 (a, b)) = mult2 (f a, f b)"
    and map_unit: "f unit1 = unit2"

subsection "Lie Subgroups"

locale lie_subgroup = lie_group charts k mult unit inv
  for charts::"('a::{t2_space,second_countable_topology}, 'b::euclidean_space) chart set" and
    k and mult and unit and inv +
  fixes S::"'a set"
  assumes open_submanifold: "open S"
    and is_subgroup: "subgroup carrier mult unit inv (S \<inter> carrier)"

abbreviation (in lie_subgroup) subcarrier where
"subcarrier \<equiv> S \<inter> carrier"

subsection \<open>Connected Lie Groups\<close>

locale connected_lie_group = c_manifold + is_group: group carrier mult unit inv for mult and unit and inv +
  assumes smooth_mult: "diff k (c_manifold_prod.prod_charts charts charts) charts mult"
    and smooth_inv: "diff k charts charts inv"
    and is_connected: "connected carrier"

locale lie_subgroup_of_connected = connected_lie_group charts k mult unit inv
  for charts::"('a::{t2_space,second_countable_topology}, 'b::euclidean_space) chart set" and
    k and mult and unit and inv +
  fixes S::"'a set"
  assumes open_submanifold: "open S"
    and is_subgroup: "subgroup carrier mult unit inv (S \<inter> carrier)"

definition is_dense:: "'a topology \<Rightarrow> 'a set \<Rightarrow> bool" where (* It should be moved somewhere else *)
"is_dense T S \<equiv> topspace T \<subseteq> T closure_of S"

context lie_subgroup_of_connected begin

abbreviation subcarrier where
"subcarrier \<equiv> S \<inter> carrier"

lemma lie_subgroup_is_closed:
  shows "closed subcarrier"
proof-
  have "subgroup carrier mult unit inv (closure subcarrier)" sorry
  moreover have coset_open:
"\<forall>x\<in>(closure subcarrier).
openin (subtopology (subtopology euclidean carrier) (closure subcarrier)) (subcarrier |\<cdot> x)" sorry
(*"\<forall>x\<in>(closure subcarrier).\<exists>U. open U \<and> (subcarrier |\<cdot> x = U \<inter> closure subcarrier)" *)
  moreover have coset_dense:
"\<forall>x\<in>(closure subcarrier).
is_dense (subtopology (subtopology euclidean carrier) (closure subcarrier)) (subcarrier |\<cdot> x)" sorry
(*"\<forall>x\<in>(closure subcarrier).\<forall>y\<in>(closure subcarrier).\<forall>U.
openin (subtopology (subtopology euclidean carrier) (closure subcarrier)) U \<and> y \<in> U \<longrightarrow>
(\<exists>z. z \<in> subcarrier |\<cdot> x \<inter> U)"*)
(*"\<forall>x\<in>(closure subcarrier).\<forall>y\<in>(closure subcarrier).\<forall>U.
(open U \<and> y\<in>(U \<inter> closure subcarrier) \<longrightarrow> (\<exists>z. z \<in> ((subcarrier |\<cdot> x) \<inter> (U \<inter> closure subcarrier))))"*)
  ultimately have "closure subcarrier = subcarrier" sorry
  thus ?thesis by (metis closed_closure)
qed

end (* lie_subgroup_of_connected *)

lemma (in topological_space) clopen_of_connected_space: (* Should be moved somewhere else *)
  fixes S carrier
  assumes "S \<subseteq> carrier" and "connected carrier" and "S \<noteq> {}" and "open S" and "closed S"
  shows "S = carrier"
proof-
  {
  assume "S \<noteq> carrier"
  then have "carrier - S \<noteq> {}"
    using assms(1) by simp
  moreover have "carrier = S \<union> (carrier - S)"
    using assms(1) by auto
  moreover have "open (carrier - S)" using assms(1,4) closed_def
    by (smt Compl_Diff_eq Diff_disjoint Diff_eq Diff_eq_empty_iff Diff_triv Int_commute Un_upper2 assms(2,3,5) calculation(1) local.connected_def)
  ultimately have "False"
    using assms(2,3,4) local.connected_def by auto
  }
  thus ?thesis by auto
qed

context connected_lie_group begin

lemma closed_subgroup_is_lie_subgroup:
  fixes H
  assumes is_subgroup: "subgroup carrier mult unit inv H" and is_closed: "closed H"
  shows "lie_subgroup charts k mult unit inv H" sorry

lemma neighborhood_of_unit_generates:
  fixes U
  assumes "open U" and "unit \<in> U \<inter> carrier"
  shows "group.subgroup_generated carrier mult unit inv (U \<inter> carrier) = carrier"
proof-
  define H where "H = group.subgroup_generated carrier mult unit inv (U \<inter> carrier)"
  then have "\<forall>h\<in>H. h \<in> {mult (h,u)| u. u \<in> U}" sorry
  moreover have "\<forall>h\<in> H. open {mult (h,u)| u. u \<in> U}" sorry
  then have "open H"
  proof-
    have "H = (\<Union> h\<in>H. {mult (h,u)| u. u \<in> U})" sorry
    thus ?thesis
      using \<open>\<forall>h\<in>H. open {h \<cdot> u |u. u \<in> U}\<close> open_UN by fastforce
  qed
  moreover have "lie_subgroup_of_connected charts k mult unit inv H"
    using \<open>open H\<close> H_def group.subgroup_generated_is_subgroup
    by (metis connected_lie_group_axioms connected_lie_group_def inf.orderE lie_subgroup_of_connected.intro
lie_subgroup_of_connected_axioms_def subgroup.subset)
  then have "closed H"
    using lie_subgroup_of_connected.lie_subgroup_is_closed
    by (metis inf.absorb1 is_group.subgroup_generated_is_subgroup local.H_def subgroup.subset)
  ultimately show "H = carrier"
  proof-
    have "unit \<in> H"
      using H_def is_group.generate.unit is_group.subgroup_generated_def by simp
    then have "H \<noteq> {}" by auto
    thus ?thesis
    proof-
      have "H \<subseteq> carrier"
        using H_def by (meson is_group.subgroup_generated_is_subgroup subgroup.subset)
      thus ?thesis
        using is_connected clopen_of_connected_space \<open>open H\<close> \<open>closed H\<close> \<open>H \<noteq> {}\<close> by auto
    qed
  qed
qed

end (* connected_lie_group *)

context lie_group_map begin

lemma surjective_pushforward_of_map_with_connected_dest:
  assumes dest_is_connected: "connected_lie_group charts2 k mult2 unit2 inv2"
    and pushforward_is_surjective:
"\<forall>Y\<in>(c_manifold.tangent_space charts2 k unit2).\<exists>X\<in>c_manifold.tangent_space charts1 k unit1.
diff.push_forward k charts1 charts2 f X = Y"
  shows "surj f" sorry

end (* lie_group_map *)

end


theory IO_Logic imports Main

abbrevs
 f_top="\<^bold>\<top>"  f_bot="\<^bold>\<bottom>" f_neg="\<^bold>\<not>"  f_or="\<^bold>\<or>" f_and="\<^bold>\<and>" f_impl="\<^bold>\<supset>" f_valid="\<lfloor>\<rfloor>"

begin
 (*Begin: some useful parameter settings*)
  declare [[ smt_solver = cvc4 ]] declare [[ show_types ]]
  nitpick_params [user_axioms, show_all, format = 2]

 (*IO logic in HOL*)
 typedecl i -- "type for possible worlds"     type_synonym e = "(i\<Rightarrow>bool)"
 abbreviation ktop   :: "e"    ("\<^bold>\<top>")  where "\<^bold>\<top> \<equiv> \<lambda>w. True"
 abbreviation kbot   :: "e"    ("\<^bold>\<bottom>")  where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
 abbreviation knot   :: "e\<Rightarrow>e"    ("\<^bold>\<not>_"[52]53)  where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>\<phi>(w)"
 abbreviation kor    :: "e\<Rightarrow>e\<Rightarrow>e" (infixr"\<^bold>\<or>"50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<or>\<psi>(w)"
 abbreviation kand   :: "e\<Rightarrow>e\<Rightarrow>e" (infixr"\<^bold>\<and>"51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<and>\<psi>(w)"
 abbreviation kimp   :: "e\<Rightarrow>e\<Rightarrow>e" (infixr"\<^bold>\<supset>"49) where "\<phi>\<^bold>\<supset>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longrightarrow>\<psi>(w)"
 abbreviation kvalid :: "e\<Rightarrow>bool" ("\<lfloor>_\<rfloor>"[8]109)  where "\<lfloor>p\<rfloor> \<equiv> \<forall>w. p w"

 abbreviation "outpre \<equiv> \<lambda>G.\<lambda>a.\<lambda>y::e. \<exists>f. \<lfloor>a \<^bold>\<supset> f\<rfloor> \<and> G (f,y)"

 abbreviation "out1 \<equiv>  \<lambda>G.\<lambda>a.\<lambda>x. \<lfloor>x\<rfloor> \<or>
    (\<exists>i j k. outpre G a i \<and> outpre G a j \<and> outpre G a k \<and> \<lfloor>(i \<^bold>\<and> j \<^bold>\<and> k) \<^bold>\<supset> x\<rfloor>)"

(* Some Tests *)
 consts a::e b::e e::e
 abbreviation "G1 \<equiv> (\<lambda>X. X=(a,e) \<or> X=(b,e))"  (* G = {(a,e),(b,e)} *)

 lemma "out1 G1 a e" by blast (*proof*)
 lemma "outpre G1 a e" by blast (*proof*)
 lemma "outpre G1 (a \<^bold>\<or> b) e" nitpick oops (*countermodel*)
 lemma "out1 G1 (a \<^bold>\<or> b) e" nitpick oops (*countermodel*)
 lemma "\<lfloor>x\<rfloor> \<Longrightarrow> outpre G1 (a \<^bold>\<or> b) x" nitpick oops (*countermodel*)
 lemma "\<lfloor>x\<rfloor> \<Longrightarrow> out1 G1 (a \<^bold>\<or> b) x" by blast (*proof*)

(* GDPR Example from before *)
 consts    pr_d_lawf::e     erase_d::e      kill_boss::e

 abbreviation (* G = {(T,pr_d_lawf),(pr_d_lawf,\<^bold>\<not>erase_d),(\<^bold>\<not>pr_d_lawf,erase_d)} *)
 "G \<equiv> (\<lambda>X. X=(\<^bold>\<top>,pr_d_lawf) \<or> X=(pr_d_lawf,\<^bold>\<not>erase_d) \<or> X=(\<^bold>\<not>pr_d_lawf,erase_d) )"

 lemma "out1 G (\<^bold>\<not>pr_d_lawf) erase_d" by smt (*proof*)
 lemma "out1 G (\<^bold>\<not>pr_d_lawf) (\<^bold>\<not>erase_d)" nitpick oops (*countermodel*)
 lemma "out1 G (\<^bold>\<not>pr_d_lawf) kill_boss"  nitpick oops (*countermodel*)
 lemma "out1 G (\<^bold>\<not>pr_d_lawf) \<^bold>\<bottom>"  nitpick oops (*countermodel*)

end


theory T140
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. over(join(x, y), z) = join(over(x, z), over(y, 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. over(x, meet(y, z)) = join(over(x, y), over(x, z)))
"
nitpick[card nat=8,timeout=86400]
oops
end


theory T104
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(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, 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. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


theory T110
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(meet(x, y), z) = join(undr(x, z), undr(y, 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. over(join(x, y), z) = join(over(x, z), over(y, z)))
"
nitpick[card nat=4,timeout=86400]
oops
end


section \<open>Functions\<close>

theory Functions
imports "../Extensions/Set_Extensions"
begin

  locale bounded_function =
    fixes A :: "'a set"
    fixes B :: "'b set"
    fixes f :: "'a \<Rightarrow> 'b"
    assumes wellformed[intro?, simp]: "x \<in> A \<Longrightarrow> f x \<in> B"

  locale bounded_function_pair =
    f: bounded_function A B f +
    g: bounded_function B A g
    for A :: "'a set"
    and B :: "'b set"
    and f :: "'a \<Rightarrow> 'b"
    and g :: "'b \<Rightarrow> 'a"

  locale injection = bounded_function_pair +
    assumes left_inverse[simp]: "x \<in> A \<Longrightarrow> g (f x) = x"
  begin

    lemma inj_on[intro]: "inj_on f A" using inj_onI left_inverse by metis

    lemma injective_on:
      assumes "x \<in> A" "y \<in> A" "f x = f y"
      shows "x = y"
      using assms left_inverse by metis

  end

  locale injective = bounded_function +
    assumes injection: "\<exists> g. injection A B f g"
  begin

    definition "g \<equiv> SOME g. injection A B f g"

    sublocale injection A B f g unfolding g_def using someI_ex[OF injection] by this

  end

  locale surjection = bounded_function_pair +
    assumes right_inverse[simp]: "y \<in> B \<Longrightarrow> f (g y) = y"
  begin

    lemma image_superset[intro]: "f ` A \<supseteq> B"
      using g.wellformed image_iff right_inverse subsetI by metis

    lemma image_eq[simp]: "f ` A = B" using image_superset by auto

  end

  locale surjective = bounded_function +
    assumes surjection: "\<exists> g. surjection A B f g"
  begin

    definition "g \<equiv> SOME g. surjection A B f g"

    sublocale surjection A B f g unfolding g_def using someI_ex[OF surjection] by this

  end

  locale bijection = injection + surjection

  lemma inj_on_bijection:
    assumes "inj_on f A"
    shows "bijection A (f ` A) f (inv_into A f)"
  proof
    show "\<And> x. x \<in> A \<Longrightarrow> f x \<in> f ` A" using imageI by this
    show "\<And> y. y \<in> f ` A \<Longrightarrow> inv_into A f y \<in> A" using inv_into_into by this
    show "\<And> x. x \<in> A \<Longrightarrow> inv_into A f (f x) = x" using inv_into_f_f assms by this
    show "\<And> y. y \<in> f ` A \<Longrightarrow> f (inv_into A f y) = y" using f_inv_into_f by this
  qed

end


(* Author: Alexander Bentkamp, Universität des Saarlandes
*)
section \<open>Missing Lemmas of Sublist\<close>

theory DL_Missing_Sublist
imports Main
begin

lemma nths_only_one:
assumes "{i. i < length xs \<and> i\<in>I} = {j}"
shows "nths xs I = [xs!j]"
proof -
  have "set (nths xs I) = {xs!j}"
    unfolding set_nths using subset_antisym assms by fastforce
  moreover have "length (nths xs I) = 1"
    unfolding length_nths assms by auto
  ultimately show ?thesis
    by (metis One_nat_def length_0_conv length_Suc_conv the_elem_eq the_elem_set)
qed

lemma nths_replicate:
"nths (replicate n x) A = (replicate (card {i. i < n \<and> i \<in> A}) x)"
proof (induction n)
  case 0
  then show ?case by simp
next
  case (Suc n)
  then show ?case
  proof (cases "n\<in>A")
    case True
    then have 0:"(if 0 \<in> {j. j + length (replicate n x) \<in> A} then [x] else []) = [x]" by simp
    have "{i. i < Suc n \<and> i \<in> A} = insert n {i. i < n \<and> i \<in> A}" using True by auto
    have "Suc (card {i. i < n \<and> i \<in> A}) = card {i. i < Suc n \<and> i \<in> A}"
      unfolding \<open>{i. i < Suc n \<and> i \<in> A} = insert n {i. i < n \<and> i \<in> A}\<close>
      using finite_Collect_conjI[THEN card_insert_if] finite_Collect_less_nat
       less_irrefl_nat mem_Collect_eq by simp
    then show ?thesis unfolding replicate_Suc replicate_append_same[symmetric] nths_append Suc nths_singleton 0
      unfolding replicate_append_same replicate_Suc[symmetric] by simp
  next
    case False
    then have 0:"(if 0 \<in> {j. j + length (replicate n x) \<in> A} then [x] else []) = []" by simp
    have "{i. i < Suc n \<and> i \<in> A} = {i. i < n \<and> i \<in> A}" using False using le_less less_Suc_eq_le by auto
    then show ?thesis unfolding replicate_Suc replicate_append_same[symmetric] nths_append Suc nths_singleton 0
      by simp
  qed
qed

lemma length_nths_even:
assumes "even (length xs)"
shows "length (nths xs (Collect even)) = length (nths xs (Collect odd))"
using assms proof (induction "length xs div 2" arbitrary:xs)
  case 0
  then have "length xs = 0"
    by (auto elim: evenE)
  then show ?case by simp
next
  case (Suc l xs)
  then have length_drop2: "length (nths (drop 2 xs) (Collect even)) = length (nths (drop 2 xs) {a. odd a})" by simp

  have "length (take 2 xs) = 2" using Suc.hyps(2) by auto
  then have plus_odd: "{j. j + length (take 2 xs) \<in> Collect odd} = Collect odd" and
            plus_even: "{j. j + length (take 2 xs) \<in> Collect even} = Collect even" by simp_all
  have nths_take2: "nths (take 2 xs) (Collect even) = [take 2 xs ! 0]" "nths (take 2 xs) (Collect odd) = [take 2 xs ! 1]"
    using \<open>length (take 2 xs) = 2\<close> less_2_cases nths_only_one[of "take 2 xs" "Collect even" 0]
    nths_only_one[of "take 2 xs" "Collect odd" 1]
    by fastforce+
  then have "length (nths (take 2 xs @ drop 2 xs) (Collect even))
           = length (nths (take 2 xs @ drop 2 xs) {a. odd a})"
    unfolding nths_append length_append plus_odd plus_even nths_take2 length_drop2
    by auto
  then show ?case using append_take_drop_id[of 2 xs] by simp
qed

lemma nths_map:
"nths (map f xs) A = map f (nths xs A)"
proof (induction xs arbitrary:A)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  then show ?case
  by (simp add: nths_Cons)
qed

section "Pick"

fun pick :: "nat set \<Rightarrow> nat \<Rightarrow> nat" where
"pick S 0 = (LEAST a. a\<in>S)" |
"pick S (Suc n) = (LEAST a. a\<in>S \<and> a > pick S n)"

lemma pick_in_set_inf:
assumes "infinite S"
shows "pick S n \<in> S"
proof (cases n)
  show "n = 0 \<Longrightarrow> pick S n \<in> S"
    unfolding pick.simps using \<open>infinite S\<close> LeastI pick.simps(1) by (metis Collect_mem_eq not_finite_existsD)
next
  fix n' assume "n = Suc n'"
  obtain a where "a\<in>S \<and> a > pick S n'" using assms by (metis bounded_nat_set_is_finite less_Suc_eq nat_neq_iff)
  show "pick S n \<in> S" unfolding \<open>n = Suc n'\<close> pick.simps(2)
    using LeastI[of "\<lambda>a. a \<in> S \<and> pick S n' < a" a, OF \<open>a\<in>S \<and> a > pick S n'\<close>] by blast
qed

lemma pick_mono_inf:
assumes "infinite S"
shows "m < n \<Longrightarrow> pick S m < pick S n"
using assms proof (induction n)
  case 0
  then show ?case by auto
next
  case (Suc n)
  then obtain a where "a \<in> S \<and> pick S n < a" by (metis bounded_nat_set_is_finite less_Suc_eq nat_neq_iff)
  then have "pick S n < pick S (Suc n)" unfolding pick.simps
    using LeastI[of "\<lambda>a. a \<in> S \<and> pick S n < a" a, OF \<open>a\<in>S \<and> a > pick S n\<close>] by simp
  then show ?case using Suc.IH Suc.prems(1) assms dual_order.strict_trans less_Suc_eq by auto
qed

lemma pick_eq_iff_inf:
assumes "infinite S"
shows "x = y \<longleftrightarrow> pick S x = pick S y"
  by (metis assms nat_neq_iff pick_mono_inf)

lemma card_le_pick_inf:
assumes "infinite S"
and "pick S n \<ge> i"
shows "card {a\<in>S. a < i} \<le> n"
using assms proof (induction n arbitrary:i)
  case 0
  then show ?case unfolding pick.simps using not_less_Least
    by (metis (no_types, lifting) Collect_empty_eq card_0_eq card_ge_0_finite dual_order.strict_trans1 leI le_0_eq)
next
  case (Suc n)
  then show ?case
  proof -
    have "card {a \<in> S. a < pick S n} \<le> n" using Suc by blast
    have "{a \<in> S. a < i} \<subseteq> {a \<in> S. a < pick S (Suc n)}" using Suc.prems(2) by auto
    have "{a \<in> S. a < pick S (Suc n)} = {a \<in> S. a < pick S n} \<union> {pick S n}"
      apply (rule subset_antisym; rule subsetI)
      using not_less_Least UnCI mem_Collect_eq nat_neq_iff singleton_conv
       pick_mono_inf[OF Suc.prems(1), of n "Suc n"] pick_in_set_inf[OF Suc.prems(1), of n] by fastforce+
    then have "card {a \<in> S. a < i} \<le> card {a \<in> S. a < pick S n} + card {pick S n}"
      using card_Un_disjoint  card_mono[OF _ \<open>{a \<in> S. a < i} \<subseteq> {a \<in> S. a < pick S (Suc n)}\<close>] by simp
    then show ?thesis using \<open>card {a \<in> S. a < pick S n} \<le> n\<close>  by auto
  qed
qed

lemma card_pick_inf:
assumes "infinite S"
shows "card {a\<in>S. a < pick S n} = n"
using assms proof (induction n)
  case 0
  then show ?case unfolding pick.simps using not_less_Least by auto
next
  case (Suc n)
  then show "card {a\<in>S. a < pick S (Suc n)} = Suc n"
  proof -
    have "{a \<in> S. a < pick S (Suc n)} = {a \<in> S. a < pick S n} \<union> {pick S n}"
      apply (rule subset_antisym; rule subsetI)
      using not_less_Least UnCI mem_Collect_eq nat_neq_iff singleton_conv
       pick_mono_inf[OF Suc.prems, of n "Suc n"] pick_in_set_inf[OF Suc.prems, of n] by fastforce+
    then have "card {a \<in> S. a < pick S (Suc n)} = card {a \<in> S. a < pick S n} + card {pick S n}"  using card_Un_disjoint by auto
    then show ?thesis by (metis One_nat_def Suc_eq_plus1 Suc card_empty card_insert_if empty_iff finite.emptyI)
  qed
qed

lemma
assumes "n < card S"
shows
  pick_in_set_le:"pick S n \<in> S" and
  card_pick_le: "card {a\<in>S. a < pick S n} = n" and
  pick_mono_le: "m < n \<Longrightarrow> pick S m < pick S n"
using assms proof (induction n)
  assume "0 < card S"
  then obtain x where "x\<in>S" by fastforce
  then show "pick S 0 \<in> S" unfolding pick.simps by (meson LeastI)
  then show "card {a \<in> S. a < pick S 0} = 0" using not_less_Least by auto
  show "m < 0 \<Longrightarrow>  pick S m < pick S 0" by auto
next
  fix n
  assume "n < card S \<Longrightarrow> pick S n \<in> S"
    and "n < card S \<Longrightarrow> card {a \<in> S. a < pick S n} = n"
    and "Suc n < card S"
    and "m < n \<Longrightarrow> n < card S \<Longrightarrow> pick S m < pick S n"
  then have "card {a \<in> S. a < pick S n} = n" "pick S n \<in> S" by linarith+
  have "card {a \<in> S. a > pick S n} > 0"
  proof -
    have "S = {a \<in> S. a < pick S n} \<union> {a \<in> S. a \<ge> pick S n}" by fastforce
    then have "card {a \<in> S. a \<ge> pick S n} > 1"
      using \<open>Suc n < card S\<close> \<open>card {a \<in> S. a < pick S n} = n\<close>
      card_Un_le[of "{a \<in> S. a < pick S n}" "{a \<in> S. pick S n \<le> a}"] by force
    then have 0:"{a \<in> S. a \<ge> pick S n} \<subseteq> {pick S n} \<union> {a \<in> S. a > pick S n}" by auto
    have 1:"finite ({pick S n} \<union> {a \<in> S. pick S n < a})"
      unfolding finite_Un using Collect_mem_eq assms card_infinite conjI by force
    have "1 < card {pick S n} + card {a \<in> S. pick S n < a}"
      using card_mono[OF 1 0] card_Un_le[of "{pick S n}" "{a \<in> S. a > pick S n}"]  \<open>card {a \<in> S. a \<ge> pick S n} > 1\<close>
      by linarith
    then show ?thesis by simp
  qed
  then show "pick S (Suc n) \<in> S" unfolding pick.simps
    by (metis (no_types, lifting) Collect_empty_eq LeastI card_0_eq card_infinite less_numeral_extra(3))
  have "pick S (Suc n) > pick S n"
    by (metis (no_types, lifting) pick.simps(2) \<open>card {a \<in> S. a > pick S n} > 0\<close> Collect_empty_eq LeastI card_0_eq card_infinite less_numeral_extra(3))
  then show "m < Suc n \<Longrightarrow> pick S m < pick S (Suc n)"
    using \<open>m < n \<Longrightarrow> n < card S \<Longrightarrow> pick S m < pick S n\<close>
    using \<open>Suc n < card S\<close> dual_order.strict_trans less_Suc_eq by auto
  then show "card {a\<in>S. a < pick S (Suc n)} = Suc n"
  proof -
    have "{a \<in> S. a < pick S (Suc n)} = {a \<in> S. a < pick S n} \<union> {pick S n}"
      apply (rule subset_antisym; rule subsetI)
      using pick.simps not_less_Least \<open>pick S (Suc n) > pick S n\<close> \<open>pick S n \<in> S\<close> by fastforce+
    then have "card {a \<in> S. a < pick S (Suc n)} = card {a \<in> S. a < pick S n} + card {pick S n}"  using card_Un_disjoint by auto
    then show ?thesis by (metis One_nat_def Suc_eq_plus1 \<open>card {a \<in> S. a < pick S n} = n\<close> card_empty card_insert_if empty_iff finite.emptyI)
  qed
qed

lemma card_le_pick_le:
assumes "n < card S"
and "pick S n \<ge> i"
shows "card {a\<in>S. a < i} \<le> n"
using assms proof (induction n arbitrary:i)
  case 0
  then show ?case unfolding pick.simps using not_less_Least
    by (metis (no_types, lifting) Collect_empty_eq card_0_eq card_ge_0_finite dual_order.strict_trans1 leI le_0_eq)
next
  case (Suc n)
  have "card {a \<in> S. a < pick S n} \<le> n" using Suc by (simp add: less_eq_Suc_le nat_less_le)
  have "{a \<in> S. a < i} \<subseteq> {a \<in> S. a < pick S (Suc n)}" using Suc.prems(2) by auto
  have "{a \<in> S. a < pick S (Suc n)} = {a \<in> S. a < pick S n} \<union> {pick S n}"
    apply (rule subset_antisym; rule subsetI)
    using pick.simps not_less_Least  pick_mono_le[OF Suc.prems(1), of n, OF lessI] pick_in_set_le[of n S] Suc by fastforce+
  then have "card {a \<in> S. a < i} \<le> card {a \<in> S. a < pick S n} + card {pick S n}"
    using card_Un_disjoint  card_mono[OF _ \<open>{a \<in> S. a < i} \<subseteq> {a \<in> S. a < pick S (Suc n)}\<close>] by simp
  then show ?case using \<open>card {a \<in> S. a < pick S n} \<le> n\<close>  by auto
qed

lemma
assumes "n < card S \<or> infinite S"
shows
  pick_in_set:"pick S n \<in> S" and
  card_le_pick: "i \<le> pick S n ==> card {a\<in>S. a < i} \<le> n" and
  card_pick: "card {a\<in>S. a < pick S n} = n" and
  pick_mono: "m < n \<Longrightarrow> pick S m < pick S n"
    using assms pick_in_set_inf pick_in_set_le card_pick_inf card_pick_le card_le_pick_le card_le_pick_inf
    pick_mono_inf pick_mono_le by auto

lemma pick_card:
"pick I (card {a\<in>I. a < i}) = (LEAST a. a\<in>I \<and> a \<ge> i)"
proof (induction i)
  case 0
  then show ?case by (simp add: pick_in_set_le)
next
  case (Suc i)
  then show ?case
  proof (cases "i\<in>I")
    case True
    then have 1:"pick I (card {a\<in>I. a < i}) = i" by (metis (mono_tags, lifting) Least_equality Suc.IH order_refl)
    have "{a \<in> I. a < Suc i} = {a \<in> I. a < i} \<union> {i}" using True by auto
    then have 2:"card {a \<in> I. a < Suc i} = Suc (card {a \<in> I. a < i})" by auto
    then show ?thesis unfolding 2 pick.simps 1 using Suc_le_eq by auto
  next
    case False
    then have 1:"{a \<in> I. a < Suc i} = {a \<in> I. a < i}" using Collect_cong less_Suc_eq by auto
    have 2:"\<And>a. (a \<in> I \<and> Suc i \<le> a) = (a \<in> I \<and> i \<le> a)" using False Suc_leD le_less_Suc_eq not_le by blast
    then show ?thesis unfolding 1 2 using Suc.IH by blast
  qed
qed

lemma pick_card_in_set: "i\<in>I \<Longrightarrow> pick I (card {a\<in>I. a < i}) = i"
  unfolding pick_card using Least_equality order_refl by (metis (no_types, lifting))

section "Sublist"

lemma nth_nths_card:
assumes "j<length xs"
and "j\<in>J"
shows "nths xs J ! card {j0. j0 < j \<and> j0 \<in> J} = xs!j"
using assms proof (induction xs rule:rev_induct)
  case Nil
  then show ?case using gr_implies_not0 list.size(3) by auto
next
  case (snoc x xs)
  then show ?case
  proof (cases "j < length xs")
    case True
    have "{j0. j0 < j \<and> j0 \<in> J} \<subset> {i. i < length xs \<and> i \<in> J}"
      using True snoc.prems(2) by auto
    then have "card {j0. j0 < j \<and> j0 \<in> J} < length (nths xs J)" unfolding length_nths
      using psubset_card_mono[of "{i. i < length xs \<and> i \<in> J}"] by simp
    then show ?thesis unfolding nths_append nth_append by (simp add: True snoc.IH snoc.prems(2))
  next
    case False
    then have "length xs = j"
      using length_append_singleton less_antisym snoc.prems(1) by auto
    then show ?thesis unfolding nths_append nth_append length_nths \<open>length xs = j\<close>
      by (simp add: snoc.prems(2))
  qed
qed

lemma pick_reduce_set:
assumes "i<card {a. a<m \<and> a\<in>I}"
shows "pick I i = pick {a. a < m \<and> a \<in> I} i"
using assms proof (induction i)
  let ?L = "LEAST a. a \<in> {a. a < m \<and> a \<in> I}"
  case 0
  then have "{a. a < m \<and> a \<in> I} \<noteq> {}" using card_empty less_numeral_extra(3) by fastforce
  then have "?L \<in> I" "?L < m" by (metis (mono_tags, lifting) Collect_empty_eq LeastI mem_Collect_eq)+
  have "\<And>x. x \<in> {a. a < m \<and> a \<in> I} \<Longrightarrow> ?L \<le> x" by (simp add: Least_le)
  have "\<And>x. x \<in> I \<Longrightarrow> ?L \<le> x"
    by (metis (mono_tags) \<open>?L < m\<close> \<open>\<And>x. x \<in> {a. a < m \<and> a \<in> I} \<Longrightarrow> ?L \<le> x\<close> dual_order.strict_trans2 le_cases mem_Collect_eq)
  then show ?case unfolding pick.simps using Least_equality[of "\<lambda>x. x\<in>I", OF \<open>?L \<in> I\<close>] by blast
next
  case (Suc i)
  let ?L = "LEAST x. x \<in> {a. a < m \<and> a \<in> I} \<and> pick I i < x"
  have 0:"pick {a. a < m \<and> a \<in> I} i = pick I i" using Suc_lessD Suc by linarith
  then have "?L \<in> {a. a < m \<and> a \<in> I}" "pick I i < ?L"
    using LeastI[of "\<lambda>a. a \<in> {a. a < m \<and> a \<in> I} \<and> pick I i < a"] using Suc.prems pick_in_set_le pick_mono_le by fastforce+
  then have "?L \<in> I" by blast
  show ?case unfolding pick.simps 0 using Least_equality[of "\<lambda>a. a \<in> I \<and> pick I i < a" ?L]
    by (metis (no_types, lifting) Least_le \<open>?L \<in> {a. a < m \<and> a \<in> I}\<close> \<open>pick I i < ?L\<close> mem_Collect_eq not_le not_less_iff_gr_or_eq order.trans)
qed

lemma nth_nths:
assumes "i<card {i. i<length xs \<and> i\<in>I}"
shows "nths xs I ! i = xs ! pick I i"
proof -
  have "{a \<in> {i. i < length xs \<and> i \<in> I}. a < pick {i. i < length xs \<and> i \<in> I} i}
        = {a.  a < pick {i. i < length xs \<and> i \<in> I} i \<and> a \<in> I}"
    using assms pick_in_set by fastforce
  then have "card {a. a < pick {i. i < length xs \<and> i \<in> I} i \<and> a \<in> I} = i"
    using card_pick_le[OF assms] by simp
  then have "nths xs I ! i = xs ! pick {i. i < length xs \<and> i \<in> I} i"
    using nth_nths_card[where j = "pick {i. i < length xs \<and> i \<in> I} i", of xs I]
    assms pick_in_set pick_in_set by auto
  then show ?thesis using pick_reduce_set using assms by auto
qed

lemma pick_UNIV: "pick UNIV j = j"
by (induction j, simp, metis (no_types, lifting) LeastI pick.simps(2)  Suc_mono UNIV_I less_Suc_eq not_less_Least)

lemma pick_le:
assumes "n < card {a. a < i \<and> a \<in> S}"
shows "pick S n < i"
proof -
  have 0:"{a \<in> {a. a < i \<and> a \<in> S}. a < i} = {a. a < i \<and> a \<in> S}" by blast
  show ?thesis apply (rule ccontr)
    using card_le_pick_le[OF assms, unfolded pick_reduce_set[OF assms, symmetric], of i, unfolded 0]
    assms not_less not_le by blast
qed

lemma prod_list_complementary_nthss:
fixes f ::"'a \<Rightarrow> 'b::comm_monoid_mult"
shows "prod_list (map f xs) = prod_list (map f (nths xs A)) *  prod_list (map f (nths xs (-A)))"
proof (induction xs rule:rev_induct)
  case Nil
  then show ?case by simp
next
  case (snoc x xs)
  show ?case unfolding map_append "prod_list.append" nths_append nths_singleton snoc
    by (cases "(length xs)\<in>A"; simp;metis mult.assoc mult.commute)
qed

lemma nths_zip: "nths (zip xs ys) I = zip (nths xs I) (nths ys I)"
proof (rule nth_equalityI)
  show "length (nths (zip xs ys) I) = length (zip (nths xs I) (nths ys I))"
  proof (cases "length xs \<le> length ys")
    case True
    then have "{i. i < length xs \<and> i \<in> I} \<subseteq> {i. i < length ys \<and> i \<in> I}" by (simp add: Collect_mono less_le_trans)
    then have "card {i. i < length xs \<and> i \<in> I} \<le> card {i. i < length ys \<and> i \<in> I}"
      by (metis (mono_tags, lifting) card_mono finite_nat_set_iff_bounded mem_Collect_eq)
    then show ?thesis unfolding length_nths length_zip using True using min_def by linarith
  next
    case False
    then have "{i. i < length ys \<and> i \<in> I} \<subseteq> {i. i < length xs \<and> i \<in> I}" by (simp add: Collect_mono less_le_trans)
    then have "card {i. i < length ys \<and> i \<in> I} \<le> card {i. i < length xs \<and> i \<in> I}"
      by (metis (mono_tags, lifting) card_mono finite_nat_set_iff_bounded mem_Collect_eq)
    then show ?thesis unfolding length_nths length_zip using False using min_def by linarith
  qed
  show "nths (zip xs ys) I ! i = zip (nths xs I) (nths ys I) ! i" if "i < length (nths (zip xs ys) I)" for i
  proof -
   have "i < length (nths xs I)" "i < length (nths ys I)"
     using that by (simp_all add: \<open>length (nths (zip xs ys) I) = length (zip (nths xs I) (nths ys I))\<close>)
   show "nths (zip xs ys) I ! i = zip (nths xs I) (nths ys I) ! i"
     unfolding nth_nths[OF \<open>i < length (nths (zip xs ys) I)\<close>[unfolded length_nths]]
     unfolding nth_zip[OF \<open>i < length (nths xs I)\<close> \<open>i < length (nths ys I)\<close>]
     unfolding nth_zip[OF pick_le[OF \<open>i < length (nths xs I)\<close>[unfolded length_nths]]
                          pick_le[OF \<open>i < length (nths ys I)\<close>[unfolded length_nths]]]
     by (metis (full_types) \<open>i < length (nths xs I)\<close> \<open>i < length (nths ys I)\<close> length_nths nth_nths)
  qed
qed

section "weave"

definition weave :: "nat set \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"weave A xs ys = map (\<lambda>i. if i\<in>A then xs!(card {a\<in>A. a<i}) else ys!(card {a\<in>-A. a<i})) [0..<length xs + length ys]"

lemma length_weave:
shows "length (weave A xs ys) = length xs + length ys"
unfolding weave_def length_map by simp

lemma nth_weave:
assumes "i < length (weave A xs ys)"
shows "weave A xs ys ! i = (if i\<in>A then xs!(card {a\<in>A. a<i}) else ys!(card {a\<in>-A. a<i}))"
proof -
  have "i < length xs + length ys" using length_weave using assms by metis
  then have "i < length [0..<length xs + length ys]" by auto
  then have "[0..<length xs + length ys] ! i = i"
    by (metis \<open>i < length xs + length ys\<close> add.left_neutral nth_upt)
  then show ?thesis
    unfolding weave_def nth_map[OF \<open>i < length [0..<length xs + length ys]\<close>] by presburger
qed

lemma weave_append1:
assumes "length xs + length ys \<in> A"
assumes "length xs = card {a\<in>A. a < length xs + length ys}"
shows "weave A (xs @ [x]) ys = weave A xs ys @ [x]"
proof (rule nth_equalityI)
  show "length (weave A (xs @ [x]) ys) = length (weave A xs ys @ [x])"
    unfolding weave_def length_map by simp
  show "weave A (xs @ [x]) ys ! i = (weave A xs ys @ [x]) ! i"
    if "i < length (weave A (xs @ [x]) ys)" for i
  proof -
    show "weave A (xs @ [x]) ys ! i = (weave A xs ys @ [x]) ! i"
    proof (cases "i = length xs + length ys")
      case True
      then have "(weave A xs ys @ [x]) ! i = x" using length_weave by (metis nth_append_length)
      have "card {a \<in> A. a < i} = length xs" using assms(2) True by auto
      then show ?thesis unfolding nth_weave[OF \<open>i < length (weave A (xs @ [x]) ys)\<close>]
        \<open>(weave A xs ys @ [x]) ! i = x\<close> using True assms(1) by simp
    next
      case False
      have "i < length (weave A xs ys)" using \<open>i < length (weave A (xs @ [x]) ys)\<close>
        \<open>length (weave A (xs @ [x]) ys) = length (weave A xs ys @ [x])\<close> length_append_singleton
        length_weave less_antisym False by fastforce
      then have "(weave A xs ys @ [x]) ! i = (weave A xs ys) ! i" by (simp add: nth_append)
      {
        assume "i\<in>A"
        have  "i<length xs + length ys" by (metis \<open>i < length (weave A xs ys)\<close> length_weave)
        then have "{a \<in> A. a < i} \<subset> {a\<in>A. a < length xs + length ys}"
          using assms(1) \<open>i<length xs + length ys\<close> \<open>i\<in>A\<close> by auto
        then have "card {a \<in> A. a < i} < card {a\<in>A. a < length xs + length ys}"
          using psubset_card_mono[of "{a\<in>A. a < length xs + length ys}" "{a \<in> A. a < i}"]  by simp
        then have "(xs @ [x]) ! card {a \<in> A. a < i} = xs ! card {a \<in> A. a < i}"
        by (metis (no_types, lifting)  assms(2) nth_append)
      }
      then show ?thesis unfolding nth_weave[OF \<open>i < length (weave A (xs @ [x]) ys)\<close>]
        \<open>(weave A xs ys @ [x]) ! i = (weave A xs ys) ! i\<close> nth_weave[OF \<open>i < length (weave A xs ys)\<close>]
        by simp
    qed
  qed
qed

lemma weave_append2:
assumes "length xs + length ys \<notin> A"
assumes "length ys = card {a\<in>-A. a < length xs + length ys}"
shows "weave A xs (ys @ [y]) = weave A xs ys @ [y]"
proof (rule nth_equalityI)
  show "length (weave A xs (ys @ [y])) = length (weave A xs ys @ [y])"
    unfolding weave_def length_map by simp
  show "weave A xs (ys @ [y]) ! i = (weave A xs ys @ [y]) ! i" if "i < length (weave A xs (ys @ [y]))" for i
  proof -
    show "weave A xs (ys @ [y]) ! i = (weave A xs ys @ [y]) ! i"
    proof (cases "i = length xs + length ys")
      case True
      then have "(weave A xs ys @ [y]) ! i = y" using length_weave by (metis nth_append_length)
      have "card {a \<in> -A. a < i} = length ys" using assms(2) True by auto
      then show ?thesis unfolding nth_weave[OF \<open>i < length (weave A xs (ys @ [y]))\<close>]
        \<open>(weave A xs ys @ [y]) ! i = y\<close> using True assms(1) by simp
    next
      case False
      have "i < length (weave A xs ys)" using \<open>i < length (weave A xs (ys @ [y]))\<close>
        \<open>length (weave A xs (ys @ [y])) = length (weave A xs ys @ [y])\<close> length_append_singleton
        length_weave less_antisym False by fastforce
      then have "(weave A xs ys @ [y]) ! i = (weave A xs ys) ! i" by (simp add: nth_append)
      {
        assume "i\<notin>A"
        have  "i<length xs + length ys" by (metis \<open>i < length (weave A xs ys)\<close> length_weave)
        then have "{a \<in> -A. a < i} \<subset> {a\<in>-A. a < length xs + length ys}"
          using assms(1) \<open>i<length xs + length ys\<close> \<open>i\<notin>A\<close> by auto
        then have "card {a \<in> -A. a < i} < card {a\<in>-A. a < length xs + length ys}"
          using psubset_card_mono[of "{a\<in>-A. a < length xs + length ys}" "{a \<in> -A. a < i}"]  by simp
        then have "(ys @ [y]) ! card {a \<in> -A. a < i} = ys ! card {a \<in> -A. a < i}"
        by (metis (no_types, lifting)  assms(2) nth_append)
      }
      then show ?thesis unfolding nth_weave[OF \<open>i < length (weave A xs (ys @ [y]))\<close>]
        \<open>(weave A xs ys @ [y]) ! i = (weave A xs ys) ! i\<close> nth_weave[OF \<open>i < length (weave A xs ys)\<close>]
        by simp
    qed
  qed
qed

lemma nths_nth:
assumes "n\<in>A" "n<length xs"
shows "nths xs A ! (card {i. i<n \<and> i\<in>A}) = xs ! n"
using assms proof (induction xs rule:rev_induct)
  case (snoc x xs)
  then show ?case
  proof (cases "n = length xs")
    case True
    then show ?thesis unfolding nths_append[of xs "[x]" A] nth_append
      using length_nths[of xs A] nths_singleton snoc.prems(1) by auto
  next
    case False
    then have "n < length xs" using snoc by auto
    then have 0:"nths xs A ! card {i. i < n \<and> i \<in> A} = xs ! n" using snoc by auto

    have "{i. i < n \<and> i \<in> A} \<subset> {i. i < length xs \<and> i \<in> A}" using \<open>n < length xs\<close> snoc by force
    then have "card {i. i < n \<and> i \<in> A} < length (nths xs A)" unfolding length_nths
      by (simp add: psubset_card_mono)
    then show ?thesis unfolding nths_append[of xs "[x]" A] nth_append using 0
      by (simp add: \<open>n < length xs\<close>)
  qed
qed simp

lemma list_all2_nths:
assumes "list_all2 P (nths xs A) (nths ys A)"
and     "list_all2 P (nths xs (-A)) (nths ys (-A))"
shows "list_all2 P xs ys"
proof -
  have "length xs = length ys"
  proof (rule ccontr; cases "length xs < length ys")
    case True
    then show False
    proof (cases "length xs \<in> A")
      case False
      have "{i. i < length xs \<and> i \<in> - A} \<subset> {i. i < length ys \<and> i \<in> - A}"
        using False \<open>length xs < length ys\<close> by force
      then have "length (nths ys (-A)) > length (nths xs (-A))"
        unfolding length_nths by (simp add: psubset_card_mono)
      then show False using assms(2) list_all2_lengthD not_less_iff_gr_or_eq by blast
    next
      case True
      have "{i. i < length xs \<and> i \<in> A} \<subset> {i. i < length ys \<and> i \<in> A}"
        using True \<open>length xs < length ys\<close> by force
      then have "length (nths ys A) > length (nths xs A)"
        unfolding length_nths by (simp add: psubset_card_mono)
      then show False using assms(1) list_all2_lengthD not_less_iff_gr_or_eq by blast
    qed
  next
    assume "length xs \<noteq> length ys"
    case False
    then have "length xs > length ys" using \<open>length xs \<noteq> length ys\<close> by auto
    then show False
    proof (cases "length ys \<in> A")
      case False
      have "{i. i < length ys \<and> i \<in> -A} \<subset> {i. i < length xs \<and> i \<in> -A}"
        using False \<open>length xs > length ys\<close>  by force
      then have "length (nths xs (-A)) > length (nths ys (-A))"
        unfolding length_nths by (simp add: psubset_card_mono)
      then show False using assms(2) list_all2_lengthD dual_order.strict_implies_not_eq by blast
    next
      case True
      have "{i. i < length ys \<and> i \<in> A} \<subset> {i. i < length xs \<and> i \<in> A}"
        using True \<open>length xs > length ys\<close> by force
      then have "length (nths xs A) > length (nths ys A)"
        unfolding length_nths by (simp add: psubset_card_mono)
      then show False using assms(1) list_all2_lengthD dual_order.strict_implies_not_eq by blast
    qed
  qed

  have "\<And>n. n < length xs \<Longrightarrow> P (xs ! n) (ys ! n)"
  proof -
    fix n assume "n < length xs"
    then have "n < length ys" using \<open>length xs = length ys\<close> by auto
    then show "P (xs ! n) (ys ! n)"
    proof (cases "n\<in>A")
      case True
      have "{i. i < n \<and> i \<in> A} \<subset> {i. i < length xs \<and> i \<in> A}" using \<open>n < length xs\<close> \<open>n\<in>A\<close> by force
      then have "card {i. i < n \<and> i \<in> A} < length (nths xs A)" unfolding length_nths
        by (simp add: psubset_card_mono)
      show ?thesis using nths_nth[OF \<open>n\<in>A\<close> \<open>n < length xs\<close>] nths_nth[OF \<open>n\<in>A\<close> \<open>n < length ys\<close>]
        list_all2_nthD[OF assms(1), of "card {i. i < n \<and> i \<in> A}"] length_nths
        by (simp add: \<open>card {i. i < n \<and> i \<in> A} < length (nths xs A)\<close>)
    next
      case False then have "n\<in>-A" by auto
      have "{i. i < n \<and> i \<in> -A} \<subset> {i. i < length xs \<and> i \<in> -A}" using \<open>n < length xs\<close> \<open>n\<in>-A\<close> by force
      then have "card {i. i < n \<and> i \<in> -A} < length (nths xs (-A))" unfolding length_nths
        by (simp add: psubset_card_mono)
      show ?thesis using nths_nth[OF \<open>n\<in>-A\<close> \<open>n < length xs\<close>] nths_nth[OF \<open>n\<in>-A\<close> \<open>n < length ys\<close>]
        list_all2_nthD[OF assms(2), of "card {i. i < n \<and> i \<in> -A}"] length_nths
        using \<open>card {i. i < n \<and> i \<in> - A} < length (nths xs (- A))\<close> by auto   next
    qed
  qed
  then show ?thesis using \<open>length xs = length ys\<close> list_all2_all_nthI by blast
qed

lemma nths_weave:
assumes "length xs = card {a\<in>A. a < length xs + length ys}"
assumes "length ys = card {a\<in>(-A). a < length xs + length ys}"
shows "nths (weave A xs ys) A = xs \<and> nths (weave A xs ys) (-A) = ys"
using assms proof (induction "length xs + length ys" arbitrary: xs ys)
  case 0
  then show ?case
    unfolding weave_def nths_map by simp
next
  case (Suc l)
  then show ?case
  proof (cases "l\<in>A")
    case True
    then have "l\<in>{a \<in> A. a < length xs + length ys}" using Suc.hyps mem_Collect_eq zero_less_Suc by auto
    then have "length xs > 0" using Suc by fastforce
    then obtain xs' x where "xs = xs' @ [x]" by (metis append_butlast_last_id length_greater_0_conv)
    then have "l = length xs' + length ys" using Suc.hyps by simp
    have length_xs':"length xs' = card {a \<in> A. a < length xs' + length ys}"
    proof -
      have "{a \<in> A. a < length xs + length ys} = {a \<in> A. a < length xs' + length ys} \<union> {l}"
        using \<open>xs = xs' @ [x]\<close> \<open>l\<in>{a \<in> A. a < length xs + length ys}\<close> \<open>l = length xs' + length ys\<close>
        by force
      then have "card {a \<in> A. a < length xs + length ys} = card {a \<in> A. a < length xs' + length ys} + 1"
        using \<open>l = length xs' + length ys\<close> by fastforce
      then show ?thesis by (metis One_nat_def Suc.prems(1) \<open>xs = xs' @ [x]\<close> add_right_imp_eq
        length_Cons length_append list.size(3))
    qed
    have length_ys:"length ys = card {a \<in> - A. a < length xs' + length ys}"
    proof -
      have "l\<notin>{a \<in> - A. a < length xs + length ys}" using \<open>l\<in>A\<close> \<open>l = length xs' + length ys\<close> by blast
      have "{a \<in> -A. a < length xs + length ys} = {a \<in> -A. a < length xs' + length ys}"
        apply (rule subset_antisym)
        using  \<open>l = length xs' + length ys\<close> \<open>Suc l = length xs + length ys\<close> \<open>l\<notin>{a \<in> - A. a < length xs + length ys}\<close>
        apply (metis (no_types, lifting) Collect_mono less_Suc_eq mem_Collect_eq)
        using Collect_mono Suc.hyps(2) \<open>l = length xs' + length ys\<close> by auto
      then show ?thesis using Suc.prems(2) by auto
    qed
    have "length xs' + length ys \<in> A" using \<open>l\<in>A\<close> \<open>l = length xs' + length ys\<close> by blast

    then have "nths (weave A xs ys) A = nths (weave A xs' ys @ [x]) A" unfolding
       \<open>xs = xs' @ [x]\<close> using weave_append1[OF \<open>length xs' + length ys \<in> A\<close> length_xs'] by metis
    also have "... = nths (weave A xs' ys) A @ nths [x] {a. a + (length xs' + length ys) \<in> A}"
      using nths_append length_weave by metis
    also have "... = nths (weave A xs' ys) A @ [x]"
      using nths_singleton \<open>length xs' + length ys \<in> A\<close> by auto
    also have "... = xs" using Suc.hyps(1)[OF \<open>l = length xs' + length ys\<close> length_xs' length_ys]
     \<open>xs = xs' @ [x]\<close> by presburger
    finally have "nths (weave A xs ys) A = xs" by metis

    have "nths (weave A xs ys) (-A) = nths (weave A xs' ys @ [x]) (-A)" unfolding
       \<open>xs = xs' @ [x]\<close> using weave_append1[OF \<open>length xs' + length ys \<in> A\<close> length_xs'] by metis
    also have "... = nths (weave A xs' ys) (-A) @ nths [x] {a. a + (length xs' + length ys) \<in> (-A)}"
      using nths_append length_weave by metis
    also have "... = nths (weave A xs' ys) (-A)"
      using nths_singleton \<open>length xs' + length ys \<in> A\<close> by auto
    also have "... = ys"
      using Suc.hyps(1)[OF \<open>l = length xs' + length ys\<close> length_xs' length_ys] by presburger
    finally show ?thesis using \<open>nths (weave A xs ys) A = xs\<close> by auto
  next
    case False
    then have "l\<notin>{a \<in> A. a < length xs + length ys}" using Suc.hyps mem_Collect_eq zero_less_Suc by auto
    then have "length ys > 0" using Suc by fastforce
    then obtain ys' y where "ys = ys' @ [y]" by (metis append_butlast_last_id length_greater_0_conv)
    then have "l = length xs + length ys'" using Suc.hyps by simp
    have length_ys':"length ys' = card {a \<in> -A. a < length xs + length ys'}"
    proof -
      have "{a \<in> -A. a < length xs + length ys} = {a \<in> -A. a < length xs + length ys'} \<union> {l}"
        using \<open>ys = ys' @ [y]\<close> \<open>l\<notin>{a \<in> A. a < length xs + length ys}\<close> \<open>l = length xs + length ys'\<close>
        by force
      then have "card {a \<in> -A. a < length xs + length ys} = card {a \<in> -A. a < length xs + length ys'} + 1"
        using \<open>l = length xs + length ys'\<close> by fastforce
      then show ?thesis by (metis One_nat_def Suc.prems(2) \<open>ys = ys' @ [y]\<close> add_right_imp_eq
        length_Cons length_append list.size(3))
    qed
    have length_xs:"length xs = card {a \<in> A. a < length xs + length ys'}"
    proof -
      have "l\<notin>{a \<in> A. a < length xs + length ys}" using \<open>l\<notin>A\<close> \<open>l = length xs + length ys'\<close> by blast
      have "{a \<in> A. a < length xs + length ys} = {a \<in> A. a < length xs + length ys'}"
        apply (rule subset_antisym)
        using  \<open>l = length xs + length ys'\<close> \<open>Suc l = length xs + length ys\<close> \<open>l\<notin>{a \<in> A. a < length xs + length ys}\<close>
        apply (metis (no_types, lifting) Collect_mono less_Suc_eq mem_Collect_eq)
        using Collect_mono Suc.hyps(2) \<open>l = length xs + length ys'\<close> by auto
      then show ?thesis using Suc.prems(1) by auto
    qed
    have "length xs + length ys' \<notin> A" using \<open>l\<notin>A\<close> \<open>l = length xs + length ys'\<close> by blast

    then have "nths (weave A xs ys) A = nths (weave A xs ys' @ [y]) A" unfolding
       \<open>ys = ys' @ [y]\<close> using weave_append2[OF \<open>length xs + length ys' \<notin> A\<close> length_ys'] by metis
    also have "... = nths (weave A xs ys') A @ nths [y] {a. a + (length xs + length ys') \<in> A}"
      using nths_append length_weave by metis
    also have "... = nths (weave A xs ys') A"
      using nths_singleton \<open>length xs + length ys' \<notin> A\<close> by auto
    also have "... = xs"
      using Suc.hyps(1)[OF \<open>l = length xs + length ys'\<close> length_xs length_ys'] by auto
    finally have "nths (weave A xs ys) A = xs" by auto

    have "nths (weave A xs ys) (-A) = nths (weave A xs ys' @ [y]) (-A)" unfolding
       \<open>ys = ys' @ [y]\<close> using weave_append2[OF \<open>length xs + length ys' \<notin> A\<close> length_ys'] by metis
    also have "... = nths (weave A xs ys') (-A) @ nths [y] {a. a + (length xs + length ys') \<in> (-A)}"
      using nths_append length_weave by metis
    also have "... = nths (weave A xs ys') (-A) @ [y]"
      using nths_singleton \<open>length xs + length ys' \<notin> A\<close> by auto
    also have "... = ys"
      using Suc.hyps(1)[OF \<open>l = length xs + length ys'\<close> length_xs length_ys'] \<open>ys = ys' @ [y]\<close> by simp
    finally show ?thesis using \<open>nths (weave A xs ys) A = xs\<close> by auto
  qed
qed

lemma set_weave:
assumes "length xs = card {a\<in>A. a < length xs + length ys}"
assumes "length ys = card {a\<in>-A. a < length xs + length ys}"
shows "set (weave A xs ys) = set xs \<union> set ys"
proof
  show "set (weave A xs ys) \<subseteq> set xs \<union> set ys"
  proof
    fix x assume "x\<in>set (weave A xs ys)"
    then obtain i where "weave A xs ys ! i = x" "i<length (weave A xs ys)" by (meson in_set_conv_nth)
    show "x \<in> set xs \<union> set ys"
    proof (cases "i\<in>A")
      case True
      then have "i \<in> {a\<in>A. a < length xs + length ys}" unfolding length_weave
        by (metis \<open>i < length (weave A xs ys)\<close> length_weave mem_Collect_eq)
      then have "{a \<in> A. a < i} \<subset> {a\<in>A. a < length xs + length ys}"
        using Collect_mono \<open>i < length (weave A xs ys)\<close>[unfolded length_weave] le_Suc_ex  less_imp_le_nat trans_less_add1
        le_neq_trans less_irrefl mem_Collect_eq by auto
      then have "card {a \<in> A. a < i} < card {a\<in>A. a < length xs + length ys}" by (simp add: psubset_card_mono)
      then show "x \<in> set xs \<union> set ys"
        unfolding nth_weave[OF \<open>i<length (weave A xs ys)\<close>, unfolded \<open>weave A xs ys ! i = x\<close>] using True
        using UnI1 assms(1) nth_mem by auto
    next
      case False
      have "i\<notin>A \<Longrightarrow> i \<in> {a\<in>-A. a < length xs + length ys}" unfolding length_weave
        by (metis ComplI \<open>i < length (weave A xs ys)\<close> length_weave mem_Collect_eq)
      then have "{a \<in> -A. a < i} \<subset> {a\<in>-A. a < length xs + length ys}"
        using Collect_mono \<open>i < length (weave A xs ys)\<close>[unfolded length_weave] le_Suc_ex  less_imp_le_nat trans_less_add1
        le_neq_trans less_irrefl mem_Collect_eq using False by auto
      then have "card {a \<in> -A. a < i} < card {a\<in>-A. a < length xs + length ys}" by (simp add: psubset_card_mono)
      then show "x \<in> set xs \<union> set ys"
        unfolding nth_weave[OF \<open>i<length (weave A xs ys)\<close>, unfolded \<open>weave A xs ys ! i = x\<close>] using False
        using UnI1 assms(2) nth_mem by auto
    qed
  qed
  show "set xs \<union> set ys \<subseteq> set (weave A xs ys)"
    using nths_weave[OF assms] by (metis Un_subset_iff set_nths_subset)
qed

lemma weave_complementary_nthss[simp]:
 "weave A (nths xs A) (nths xs (-A)) = xs"
proof (induction xs rule:rev_induct)
  case Nil
  then show ?case by (metis gen_length_def length_0_conv length_code length_weave nths_nil)
next
  case (snoc x xs)
  have length_xs:"length xs = length (nths xs A) + length (nths xs (-A))" by (metis length_weave snoc.IH)
  show ?case
  proof (cases "(length xs)\<in>A")
    case True
    have 0:"length (nths xs A) + length (nths xs (-A)) \<in> A" using length_xs True by metis
    have 1:"length (nths xs A) = card {a \<in> A. a < length (nths xs A) + length (nths xs (-A))}"
      using length_nths[of xs A] by (metis (no_types, lifting) Collect_cong length_xs)
    have 2:"nths (xs @ [x]) A = nths xs A @ [x]"
      unfolding nths_append[of xs "[x]" A] using nths_singleton True by auto
    have 3:"nths (xs @ [x]) (-A) = nths xs (-A)"
      unfolding nths_append[of xs "[x]" "-A"] using True by auto
    show ?thesis unfolding 2 3 weave_append1[OF 0 1] snoc.IH by metis
  next
    case False
    have 0:"length (nths xs A) + length (nths xs (-A)) \<notin> A" using length_xs False by metis
    have 1:"length (nths xs (-A)) = card {a \<in> -A. a < length (nths xs A) + length (nths xs (-A))}"
      using length_nths[of xs "-A"] by (metis (no_types, lifting) Collect_cong length_xs)
    have 2:"nths (xs @ [x]) A = nths xs A"
      unfolding nths_append[of xs "[x]" A] using nths_singleton False by auto
    have 3:"nths (xs @ [x]) (-A) = nths xs (-A) @ [x]"
      unfolding nths_append[of xs "[x]" "-A"] using False by auto
    show ?thesis unfolding 2 3 weave_append2[OF 0 1] snoc.IH by metis
  qed
qed

lemma length_nths': "length (nths xs I) = card {i\<in>I. i < length xs}"
unfolding length_nths by meson

end


(*  Title:      HOL/ex/PresburgerEx.thy
    Author:     Amine Chaieb, TU Muenchen
*)

section \<open>Some examples for Presburger Arithmetic\<close>

theory PresburgerEx
imports Presburger
begin

lemma "\<And>m n ja ia. \<lbrakk>\<not> m \<le> j; \<not> (n::nat) \<le> i; (e::nat) \<noteq> 0; Suc j \<le> ja\<rbrakk> \<Longrightarrow> \<exists>m. \<forall>ja ia. m \<le> ja \<longrightarrow> (if j = ja \<and> i = ia then e else 0) = 0" by presburger
lemma "(0::nat) < emBits mod 8 \<Longrightarrow> 8 + emBits div 8 * 8 - emBits = 8 - emBits mod 8"
by presburger
lemma "(0::nat) < emBits mod 8 \<Longrightarrow> 8 + emBits div 8 * 8 - emBits = 8 - emBits mod 8"
by presburger

theorem "(\<forall>(y::int). 3 dvd y) ==> \<forall>(x::int). b < x --> a \<le> x"
  by presburger

theorem "!! (y::int) (z::int) (n::int). 3 dvd z ==> 2 dvd (y::int) ==>
  (\<exists>(x::int).  2*x =  y) & (\<exists>(k::int). 3*k = z)"
  by presburger

theorem "!! (y::int) (z::int) n. Suc(n::nat) < 6 ==>  3 dvd z ==>
  2 dvd (y::int) ==> (\<exists>(x::int).  2*x =  y) & (\<exists>(k::int). 3*k = z)"
  by presburger

theorem "\<forall>(x::nat). \<exists>(y::nat). (0::nat) \<le> 5 --> y = 5 + x "
  by presburger

text\<open>Slow: about 7 seconds on a 1.6GHz machine.\<close>
theorem "\<forall>(x::nat). \<exists>(y::nat). y = 5 + x | x div 6 + 1= 2"
  by presburger

theorem "\<exists>(x::int). 0 < x"
  by presburger

theorem "\<forall>(x::int) y. x < y --> 2 * x + 1 < 2 * y"
  by presburger

theorem "\<forall>(x::int) y. 2 * x + 1 \<noteq> 2 * y"
  by presburger

theorem "\<exists>(x::int) y. 0 < x  & 0 \<le> y  & 3 * x - 5 * y = 1"
  by presburger

theorem "~ (\<exists>(x::int) (y::int) (z::int). 4*x + (-6::int)*y = 1)"
  by presburger

theorem "\<forall>(x::int). b < x --> a \<le> x"
  apply (presburger elim)
  oops

theorem "~ (\<exists>(x::int). False)"
  by presburger

theorem "\<forall>(x::int). (a::int) < 3 * x --> b < 3 * x"
  apply (presburger elim)
  oops

theorem "\<forall>(x::int). (2 dvd x) --> (\<exists>(y::int). x = 2*y)"
  by presburger

theorem "\<forall>(x::int). (2 dvd x) --> (\<exists>(y::int). x = 2*y)"
  by presburger

theorem "\<forall>(x::int). (2 dvd x) = (\<exists>(y::int). x = 2*y)"
  by presburger

theorem "\<forall>(x::int). ((2 dvd x) = (\<forall>(y::int). x \<noteq> 2*y + 1))"
  by presburger

theorem "~ (\<forall>(x::int).
            ((2 dvd x) = (\<forall>(y::int). x \<noteq> 2*y+1) |
             (\<exists>(q::int) (u::int) i. 3*i + 2*q - u < 17)
             --> 0 < x | ((~ 3 dvd x) &(x + 8 = 0))))"
  by presburger

theorem "~ (\<forall>(i::int). 4 \<le> i --> (\<exists>x y. 0 \<le> x & 0 \<le> y & 3 * x + 5 * y = i))"
  by presburger

theorem "\<forall>(i::int). 8 \<le> i --> (\<exists>x y. 0 \<le> x & 0 \<le> y & 3 * x + 5 * y = i)"
  by presburger

theorem "\<exists>(j::int). \<forall>i. j \<le> i --> (\<exists>x y. 0 \<le> x & 0 \<le> y & 3 * x + 5 * y = i)"
  by presburger

theorem "~ (\<forall>j (i::int). j \<le> i --> (\<exists>x y. 0 \<le> x & 0 \<le> y & 3 * x + 5 * y = i))"
  by presburger

text\<open>Slow: about 5 seconds on a 1.6GHz machine.\<close>
theorem "(\<exists>m::nat. n = 2 * m) --> (n + 1) div 2 = n div 2"
  by presburger

text\<open>This following theorem proves that all solutions to the
recurrence relation $x_{i+2} = |x_{i+1}| - x_i$ are periodic with
period 9.  The example was brought to our attention by John
Harrison. It does does not require Presburger arithmetic but merely
quantifier-free linear arithmetic and holds for the rationals as well.

Warning: it takes (in 2006) over 4.2 minutes!\<close>

lemma "\<lbrakk> x3 = \<bar>x2\<bar> - x1; x4 = \<bar>x3\<bar> - x2; x5 = \<bar>x4\<bar> - x3;
         x6 = \<bar>x5\<bar> - x4; x7 = \<bar>x6\<bar> - x5; x8 = \<bar>x7\<bar> - x6;
         x9 = \<bar>x8\<bar> - x7; x10 = \<bar>x9\<bar> - x8; x11 = \<bar>x10\<bar> - x9 \<rbrakk>
 \<Longrightarrow> x1 = x10 & x2 = (x11::int)"
by arith

end


theory RLM_learn
  imports  "./providedLibs/verML-1/LearningTheory" "Strong_Convexity"
begin

definition pred_err_loss :: "('a \<times> 'b) pmf \<Rightarrow>  ('c  \<Rightarrow> ('a \<times> 'b) \<Rightarrow>  real)
 \<Rightarrow> 'c \<Rightarrow> real" where
  "pred_err_loss D l h = measure_pmf.expectation D (\<lambda> z. (l h z))"

definition train_err_loss :: " (nat \<Rightarrow> ('a * 'b)) \<Rightarrow> nat \<Rightarrow>
('c \<Rightarrow> ('a \<times> 'b) \<Rightarrow> real) \<Rightarrow> 'c \<Rightarrow>  real" where
  "train_err_loss S n l h = sum (\<lambda>i. l h (S i) ) {0..<n} / n"

lemma train_err_loss_nn: "(\<forall>i\<in>{0..<n}. l h (S i) \<ge>0) \<Longrightarrow> train_err_loss S n l h \<ge> 0"
proof -
  assume "\<forall>i\<in>{0..<n}. 0 \<le> l h (S i)"
  then have "0 \<le> (\<Sum>i\<in>{0..<n}. l h (S i))"
    by (meson sum_nonneg)
  then have " 0 \<le> sum (\<lambda>i. l h (S i) ) {0..<n}" by auto
  then show "train_err_loss S n l h \<ge> 0" unfolding train_err_loss_def  by simp
qed

text\<open>Show L_s(w) is convex over H, when the loss function is convex over H\<close>
lemma train_err_loss_if_convex: "(\<forall>i \<in>{0..<n} . convex_on H (\<lambda> h. l h (S i))) \<Longrightarrow>
   convex_on H (train_err_loss S n l)"
proof -
  assume 1: "(\<forall>i \<in> {0..<n}. convex_on H (\<lambda> h. l h (S i)))"
  then have 2: "convex_on H (\<Sum>i\<in>{0..<n}. (\<lambda> h. l h (S i)))"
  proof(induct n)
    case 0
    then show ?case
      by (simp add: convex_on_def zero_fun_def)
  next
    case (Suc n)
    then show  "convex_on H (\<Sum>i = 0..<Suc n.(\<lambda>h. l h (S i)))"
      by (simp add: Suc.hyps Suc.prems convex_fun_add)
  qed
  have "(\<Sum>i = 0..<n.(\<lambda>h. l h (S i))) = (\<lambda>h. \<Sum>i = 0..<n. l h (S i))"
  proof(induct n)
    case 0
    then show ?case
      by (simp add: zero_fun_def)
  next
    case (Suc n)
    then show ?case  by (simp add: Suc.hyps Suc.prems)
  qed
  then have 3:" convex_on H (\<lambda>h. \<Sum>i = 0..<n. l h (S i))" using 2 by simp
  have " (1/n)\<ge> 0" by auto
  then have "convex_on H  (\<lambda> h. (1/n)*(sum (\<lambda>i. l h (S i)) {0..<n}) )" using convex_on_cmul 3
    by blast
  then have "convex_on H  (\<lambda> h.(sum (\<lambda>i. l h (S i)) {0..<n})/n )" by auto
  then show "convex_on H (train_err_loss S n l)"  unfolding train_err_loss_def by blast
qed

text\<open>Define a locale for cleaner proofs and definitions\<close>
locale learning_basics1 =

fixes H :: "'a::{euclidean_space} set"
  and D :: "('b \<times> 'c) pmf"
  and n :: "nat"
  and l :: "('a  \<Rightarrow> ('b \<times> 'c) \<Rightarrow> real)"
  and k :: "real"
assumes nnH: "H \<noteq> {}"
  and  convH: "convex H"
  and l_pos: "\<forall>h\<in>H. \<forall>z\<in>D. l h z \<ge> 0"
  and convll : "\<forall>z \<in> D. convex_on H (\<lambda> h. l h z)"
  and n_pos: "n\<ge>1"
 and k_pos : "k>0"
begin

text \<open>"Regularized Loss Minimization"
Its learning rule RLMe chooses for a given training set S an Hypothesis h from H
which minimizes the training error + regularisation function. \<close>

definition RLM :: "(nat \<Rightarrow> ('b * 'c)) \<Rightarrow> ('a::euclidean_space \<Rightarrow> real) \<Rightarrow> 'a::euclidean_space set" where
  "RLM S' r = {h. is_arg_min (train_err_loss S' n l + r) (\<lambda>s. s\<in>H) h}"

definition RLMe :: "(nat \<Rightarrow> ('b * 'c)) \<Rightarrow> ('a::euclidean_space \<Rightarrow> real) \<Rightarrow> 'a::euclidean_space" where
  "RLMe S' r = (SOME h. h\<in> RLM S' r)"

definition RLMridge :: "(nat \<Rightarrow> ('b * 'c)) \<Rightarrow> real \<Rightarrow> 'a::euclidean_space" where
  "RLMridge S' k' = (SOME h. h\<in> RLM S' (\<lambda> x. k' * (norm x)^2))"

fun ridge_fun :: "(nat \<Rightarrow> ('b * 'c)) \<Rightarrow> real \<Rightarrow> ('a \<Rightarrow> real)" where
  "ridge_fun S' k' = (train_err_loss S' n l + (\<lambda> w. k' * (norm w)^2))"

definition ridge_argmin :: "(nat \<Rightarrow> ('b * 'c)) \<Rightarrow> real \<Rightarrow> 'a::euclidean_space set" where
  "ridge_argmin S' k' = {h. is_arg_min (ridge_fun S' k') (\<lambda>s. s\<in>H) h}"

definition ridge_mine :: "(nat \<Rightarrow> ('b * 'c)) \<Rightarrow> real \<Rightarrow> 'a::euclidean_space" where
  "ridge_mine S' k' = (SOME h. h \<in> ridge_argmin S' k')"

definition swapped_S :: "(nat \<Rightarrow> ('b * 'c)) \<Rightarrow> nat \<Rightarrow> nat  \<Rightarrow> (nat \<Rightarrow> ('b * 'c))" where
  "swapped_S S' i m =  S'(i:= S' m, m:= S' i) "

definition truncated_S :: "(nat \<Rightarrow> ('b * 'c))  \<Rightarrow> nat \<Rightarrow>(nat \<Rightarrow> ('b * 'c))" where
  "truncated_S S' m =  S'(m := undefined) "

text\<open>S_index is a set where the i-th data point in S is replaced with an arbitrary one\<close>
definition S_index :: "(nat \<Rightarrow> ('b \<times> 'c)) \<Rightarrow> nat \<Rightarrow> ('b \<times> 'c) \<Rightarrow> (nat \<Rightarrow> ('b * 'c))" where
  "S_index S' i z = S'(i := z)"

lemma set_pmf_Pi_pmf: "\<And>S i. finite A \<Longrightarrow> S \<in> set_pmf (Pi_pmf A dflt Q)
                   \<Longrightarrow> i \<in> A \<Longrightarrow> S i \<in> set_pmf (Q i)"
  apply(subst set_pmf_iff)
  apply(subst (asm) set_pmf_iff)
  apply(subst (asm) pmf_Pi) apply simp apply auto
  using prod_zero by metis

lemma sample_in_D: "\<forall>S \<in> (Samples m D). \<forall>i\<in>{0..<m}. S i \<in>  D"
   unfolding Samples_def  using  set_pmf_Pi_pmf
   by (metis finite_atLeastLessThan)

lemma train_err_loss_convex: "\<forall>S \<in> (Samples n D).convex_on H (train_err_loss S n l)"
  using train_err_loss_if_convex convll sample_in_D  by blast

lemma ridge_strong_convex: "\<forall>S \<in> (Samples n D). strong_convex_on H (ridge_fun S k) (2*k)"
proof
  fix S
  assume "S \<in> (Samples n D)"
  show "strong_convex_on H (ridge_fun S k) (2*k)"
  proof -
    have "strong_convex_on H (\<lambda> w. k * (norm w)*(norm w)) (2*k)" using sq_norm_strong_convex
      by blast
    moreover  have  "(\<lambda> w. k * (norm w)*(norm w)) = (\<lambda> w. k * (norm w)^2)" using power2_eq_square
      by (simp add: semiring_normalization_rules(17) semiring_normalization_rules(29))

    ultimately  have "strong_convex_on H (\<lambda> w. k * (norm w)^2) (2*k)" using
        strong_conv_if_eq by auto

    then have "strong_convex_on H (train_err_loss S n l + (\<lambda> w. k * (norm w)^2)) (2*k)"
      using strong_convex_sum train_err_loss_convex add.commute `S \<in> (Samples n D)` by metis
    then show ?thesis by auto
  qed
qed

lemma ridge_convex:
  shows "\<forall>S \<in> (Samples n D). convex_on H (ridge_fun S k)"
  using strong_conv_then_conv ridge_strong_convex k_pos by smt

lemma convex_has_min:
  fixes f :: " _ \<Rightarrow> real"
  assumes "convex_on H f"
  shows "\<exists>x\<in>H. is_arg_min f (\<lambda>z. z\<in>H) x"
  sorry

lemma in_argmin:
assumes k_pos: "k > 0"
shows"\<forall>S \<in> (Samples n D). (ridge_mine S k) \<in> (ridge_argmin S k)"
proof
  fix S
  assume " S \<in> Samples n D"
  show "(ridge_mine S k) \<in> (ridge_argmin S k)"
  proof -
    have "\<exists>h. is_arg_min (ridge_fun S k) (\<lambda>s. s \<in> H) h" using
        `S \<in> (Samples n D)` ridge_convex k_pos convex_has_min nnH convH by auto
    then have "ridge_argmin S k \<noteq> {}" unfolding ridge_argmin_def using nnH convH
      by blast
    then show  "(ridge_mine S k) \<in> (ridge_argmin S k)"
      unfolding ridge_mine_def using some_in_eq by blast
  qed
qed

lemma S_index_swap_same: "truncated_S (S_index S i (S n)) n =
                    truncated_S (swapped_S S i n) n"
  unfolding truncated_S_def unfolding S_index_def unfolding swapped_S_def
  by auto

lemma pred_err_loss_nn:
  assumes "h\<in>H"
  shows "pred_err_loss D l h \<ge> 0" unfolding pred_err_loss_def
proof -
  have "\<forall>z\<in>D. l h z \<ge> 0" using l_pos `h\<in>H` by auto
  then show "integral\<^sup>L D (\<lambda> z. l h z) \<ge> 0"
    by (simp add: AE_measure_pmf_iff integral_nonneg_AE)
qed

end

end


section \<open>Monad-Zero-Plus Class\<close>

theory Monad_Zero_Plus
imports Monad_Zero Monad_Plus
begin

hide_const (open) Fixrec.mplus

class functor_zero_plus = functor_zero + functor_plus +
  assumes plusU_zeroU_left:
    "plusU\<cdot>zeroU\<cdot>m = m"
  assumes plusU_zeroU_right:
    "plusU\<cdot>m\<cdot>zeroU = m"

class monad_zero_plus = monad_zero + monad_plus + functor_zero_plus

lemma fplus_fzero_left:
  fixes m :: "'a\<cdot>'f::functor_zero_plus"
  shows "fplus\<cdot>fzero\<cdot>m = m"
unfolding fplus_def fzero_def
by (simp add: coerce_simp plusU_zeroU_left)

lemma fplus_fzero_right:
  fixes m :: "'a\<cdot>'f::functor_zero_plus"
  shows "fplus\<cdot>m\<cdot>fzero = m"
unfolding fplus_def fzero_def
by (simp add: coerce_simp plusU_zeroU_right)

lemmas mplus_mzero_left =
  fplus_fzero_left [where 'f="'m::monad_zero_plus"] for f

lemmas mplus_mzero_right =
  fplus_fzero_right [where 'f="'m::monad_zero_plus"] for f

end


(*  Title:      ZF/Cardinal_AC.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge

These results help justify infinite-branching datatypes
*)

section\<open>Cardinal Arithmetic Using AC\<close>

theory Cardinal_AC imports CardinalArith Zorn begin

subsection\<open>Strengthened Forms of Existing Theorems on Cardinals\<close>

lemma cardinal_eqpoll: "|A| \<approx> A"
apply (rule AC_well_ord [THEN exE])
apply (erule well_ord_cardinal_eqpoll)
done

text\<open>The theorem @{term "||A|| = |A|"}\<close>
lemmas cardinal_idem = cardinal_eqpoll [THEN cardinal_cong, simp]

lemma cardinal_eqE: "|X| = |Y| ==> X \<approx> Y"
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule well_ord_cardinal_eqE, assumption+)
done

lemma cardinal_eqpoll_iff: "|X| = |Y| \<longleftrightarrow> X \<approx> Y"
by (blast intro: cardinal_cong cardinal_eqE)

lemma cardinal_disjoint_Un:
     "[| |A|=|B|;  |C|=|D|;  A \<inter> C = 0;  B \<inter> D = 0 |]
      ==> |A \<union> C| = |B \<union> D|"
by (simp add: cardinal_eqpoll_iff eqpoll_disjoint_Un)

lemma lepoll_imp_Card_le: "A \<lesssim> B ==> |A| \<le> |B|"
apply (rule AC_well_ord [THEN exE])
apply (erule well_ord_lepoll_imp_Card_le, assumption)
done

lemma cadd_assoc: "(i \<oplus> j) \<oplus> k = i \<oplus> (j \<oplus> k)"
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule well_ord_cadd_assoc, assumption+)
done

lemma cmult_assoc: "(i \<otimes> j) \<otimes> k = i \<otimes> (j \<otimes> k)"
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule well_ord_cmult_assoc, assumption+)
done

lemma cadd_cmult_distrib: "(i \<oplus> j) \<otimes> k = (i \<otimes> k) \<oplus> (j \<otimes> k)"
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule well_ord_cadd_cmult_distrib, assumption+)
done

lemma InfCard_square_eq: "InfCard(|A|) ==> A*A \<approx> A"
apply (rule AC_well_ord [THEN exE])
apply (erule well_ord_InfCard_square_eq, assumption)
done

subsection \<open>The relationship between cardinality and le-pollence\<close>

lemma Card_le_imp_lepoll:
  assumes "|A| \<le> |B|" shows "A \<lesssim> B"
proof -
  have "A \<approx> |A|"
    by (rule cardinal_eqpoll [THEN eqpoll_sym])
  also have "... \<lesssim> |B|"
    by (rule le_imp_subset [THEN subset_imp_lepoll]) (rule assms)
  also have "... \<approx> B"
    by (rule cardinal_eqpoll)
  finally show ?thesis .
qed

lemma le_Card_iff: "Card(K) ==> |A| \<le> K \<longleftrightarrow> A \<lesssim> K"
apply (erule Card_cardinal_eq [THEN subst], rule iffI,
       erule Card_le_imp_lepoll)
apply (erule lepoll_imp_Card_le)
done

lemma cardinal_0_iff_0 [simp]: "|A| = 0 \<longleftrightarrow> A = 0"
apply auto
apply (drule cardinal_0 [THEN ssubst])
apply (blast intro: eqpoll_0_iff [THEN iffD1] cardinal_eqpoll_iff [THEN iffD1])
done

lemma cardinal_lt_iff_lesspoll:
  assumes i: "Ord(i)" shows "i < |A| \<longleftrightarrow> i \<prec> A"
proof
  assume "i < |A|"
  hence  "i \<prec> |A|"
    by (blast intro: lt_Card_imp_lesspoll Card_cardinal)
  also have "...  \<approx> A"
    by (rule cardinal_eqpoll)
  finally show "i \<prec> A" .
next
  assume "i \<prec> A"
  also have "...  \<approx> |A|"
    by (blast intro: cardinal_eqpoll eqpoll_sym)
  finally have "i \<prec> |A|" .
  thus  "i < |A|" using i
    by (force intro: cardinal_lt_imp_lt lesspoll_cardinal_lt)
qed

lemma cardinal_le_imp_lepoll: " i \<le> |A| ==> i \<lesssim> A"
  by (blast intro: lt_Ord Card_le_imp_lepoll Ord_cardinal_le le_trans)

subsection\<open>Other Applications of AC\<close>

lemma surj_implies_inj:
  assumes f: "f \<in> surj(X,Y)" shows "\<exists>g. g \<in> inj(Y,X)"
proof -
  from f AC_Pi [of Y "%y. f-``{y}"]
  obtain z where z: "z \<in> (\<Prod>y\<in>Y. f -`` {y})"
    by (auto simp add: surj_def) (fast dest: apply_Pair)
  show ?thesis
    proof
      show "z \<in> inj(Y, X)" using z surj_is_fun [OF f]
        by (blast dest: apply_type Pi_memberD
                  intro: apply_equality Pi_type f_imp_injective)
    qed
qed

text\<open>Kunen's Lemma 10.20\<close>
lemma surj_implies_cardinal_le:
  assumes f: "f \<in> surj(X,Y)" shows "|Y| \<le> |X|"
proof (rule lepoll_imp_Card_le)
  from f [THEN surj_implies_inj] obtain g where "g \<in> inj(Y,X)" ..
  thus "Y \<lesssim> X"
    by (auto simp add: lepoll_def)
qed

text\<open>Kunen's Lemma 10.21\<close>
lemma cardinal_UN_le:
  assumes K: "InfCard(K)"
  shows "(!!i. i\<in>K ==> |X(i)| \<le> K) ==> |\<Union>i\<in>K. X(i)| \<le> K"
proof (simp add: K InfCard_is_Card le_Card_iff)
  have [intro]: "Ord(K)" by (blast intro: InfCard_is_Card Card_is_Ord K)
  assume "!!i. i\<in>K ==> X(i) \<lesssim> K"
  hence "!!i. i\<in>K ==> \<exists>f. f \<in> inj(X(i), K)" by (simp add: lepoll_def)
  with AC_Pi obtain f where f: "f \<in> (\<Prod>i\<in>K. inj(X(i), K))"
    by force
  { fix z
    assume z: "z \<in> (\<Union>i\<in>K. X(i))"
    then obtain i where i: "i \<in> K" "Ord(i)" "z \<in> X(i)"
      by (blast intro: Ord_in_Ord [of K])
    hence "(\<mu> i. z \<in> X(i)) \<le> i" by (fast intro: Least_le)
    hence "(\<mu> i. z \<in> X(i)) < K" by (best intro: lt_trans1 ltI i)
    hence "(\<mu> i. z \<in> X(i)) \<in> K" and "z \<in> X(\<mu> i. z \<in> X(i))"
      by (auto intro: LeastI ltD i)
  } note mems = this
  have "(\<Union>i\<in>K. X(i)) \<lesssim> K \<times> K"
    proof (unfold lepoll_def)
      show "\<exists>f. f \<in> inj(\<Union>RepFun(K, X), K \<times> K)"
        apply (rule exI)
        apply (rule_tac c = "%z. \<langle>\<mu> i. z \<in> X(i), f ` (\<mu> i. z \<in> X(i)) ` z\<rangle>"
                    and d = "%\<langle>i,j\<rangle>. converse (f`i) ` j" in lam_injective)
        apply (force intro: f inj_is_fun mems apply_type Perm.left_inverse)+
        done
    qed
  also have "... \<approx> K"
    by (simp add: K InfCard_square_eq InfCard_is_Card Card_cardinal_eq)
  finally show "(\<Union>i\<in>K. X(i)) \<lesssim> K" .
qed

text\<open>The same again, using @{term csucc}\<close>
lemma cardinal_UN_lt_csucc:
     "[| InfCard(K);  \<And>i. i\<in>K \<Longrightarrow> |X(i)| < csucc(K) |]
      ==> |\<Union>i\<in>K. X(i)| < csucc(K)"
by (simp add: Card_lt_csucc_iff cardinal_UN_le InfCard_is_Card Card_cardinal)

text\<open>The same again, for a union of ordinals.  In use, j(i) is a bit like rank(i),
  the least ordinal j such that i:Vfrom(A,j).\<close>
lemma cardinal_UN_Ord_lt_csucc:
     "[| InfCard(K);  \<And>i. i\<in>K \<Longrightarrow> j(i) < csucc(K) |]
      ==> (\<Union>i\<in>K. j(i)) < csucc(K)"
apply (rule cardinal_UN_lt_csucc [THEN Card_lt_imp_lt], assumption)
apply (blast intro: Ord_cardinal_le [THEN lt_trans1] elim: ltE)
apply (blast intro!: Ord_UN elim: ltE)
apply (erule InfCard_is_Card [THEN Card_is_Ord, THEN Card_csucc])
done

subsection\<open>The Main Result for Infinite-Branching Datatypes\<close>

text\<open>As above, but the index set need not be a cardinal. Work
backwards along the injection from @{term W} into @{term K}, given
that @{term"W\<noteq>0"}.\<close>

lemma inj_UN_subset:
  assumes f: "f \<in> inj(A,B)" and a: "a \<in> A"
  shows "(\<Union>x\<in>A. C(x)) \<subseteq> (\<Union>y\<in>B. C(if y \<in> range(f) then converse(f)`y else a))"
proof (rule UN_least)
  fix x
  assume x: "x \<in> A"
  hence fx: "f ` x \<in> B" by (blast intro: f inj_is_fun [THEN apply_type])
  have "C(x) \<subseteq> C(if f ` x \<in> range(f) then converse(f) ` (f ` x) else a)"
    using f x by (simp add: inj_is_fun [THEN apply_rangeI])
  also have "... \<subseteq> (\<Union>y\<in>B. C(if y \<in> range(f) then converse(f) ` y else a))"
    by (rule UN_upper [OF fx])
  finally show "C(x) \<subseteq> (\<Union>y\<in>B. C(if y \<in> range(f) then converse(f)`y else a))" .
qed

theorem le_UN_Ord_lt_csucc:
  assumes IK: "InfCard(K)" and WK: "|W| \<le> K" and j: "\<And>w. w\<in>W \<Longrightarrow> j(w) < csucc(K)"
  shows "(\<Union>w\<in>W. j(w)) < csucc(K)"
proof -
  have CK: "Card(K)"
    by (simp add: InfCard_is_Card IK)
  then obtain f where f: "f \<in> inj(W, K)" using WK
    by(auto simp add: le_Card_iff lepoll_def)
  have OU: "Ord(\<Union>w\<in>W. j(w))" using j
    by (blast elim: ltE)
  note lt_subset_trans [OF _ _ OU, trans]
  show ?thesis
    proof (cases "W=0")
      case True  \<comment>\<open>solve the easy 0 case\<close>
      thus ?thesis by (simp add: CK Card_is_Ord Card_csucc Ord_0_lt_csucc)
    next
      case False
        then obtain x where x: "x \<in> W" by blast
        have "(\<Union>x\<in>W. j(x)) \<subseteq> (\<Union>k\<in>K. j(if k \<in> range(f) then converse(f) ` k else x))"
          by (rule inj_UN_subset [OF f x])
        also have "... < csucc(K)" using IK
          proof (rule cardinal_UN_Ord_lt_csucc)
            fix k
            assume "k \<in> K"
            thus "j(if k \<in> range(f) then converse(f) ` k else x) < csucc(K)" using f x j
              by (simp add: inj_converse_fun [THEN apply_type])
          qed
        finally show ?thesis .
    qed
qed

end