import data.finset
import .list_pi

universes u v

inductive circuit (α : Type u) : Type u
| true : circuit
| false : circuit
| var : α → circuit
| and : circuit → circuit → circuit
| or : circuit → circuit → circuit
| not : circuit → circuit
| xor : circuit → circuit → circuit

namespace circuit
variables {α : Type u} {β : Type v}

def reppr [has_repr α] : (circuit α) → string
| true := "⊤"
| false := "⊥"
| (var x) := repr x
| (and x y) := "(" ++ reppr x ++ " ∧ " ++ reppr y ++ ")"
| (or x y) := "(" ++ reppr x ++ " ∨ " ++ reppr y ++ ")"
| (not x) := "¬" ++ reppr x
| (xor x y) := "(" ++ reppr x ++ " ⊕ " ++ reppr y ++ ")"

instance [has_repr α] : has_repr (circuit α) := ⟨reppr⟩

def vars [decidable_eq α] : circuit α → list α
| true := []
| false := []
| (var x) := [x]
| (and c₁ c₂) := (vars c₁ ++ vars c₂).dedup
| (or c₁ c₂) := (vars c₁ ++ vars c₂).dedup
| (not c) := vars c
| (xor c₁ c₂) := (vars c₁ ++ vars c₂).dedup

@[simp] def eval : circuit α → (α → bool) → bool
| true _ := tt
| false _ := ff
| (var x) f := f x
| (and c₁ c₂) f := (eval c₁ f) && (eval c₂ f)
| (or c₁ c₂) f := (eval c₁ f) || (eval c₂ f)
| (not c) f := bnot (eval c f)
| (xor c₁ c₂) f := bxor (eval c₁ f) (eval c₂ f)

@[simp] def evalv [decidable_eq α] : Π (c : circuit α), (Π a ∈ vars c, bool) → bool
| true _ := tt
| false _ := ff
| (var x) f := f x (by simp [vars])
| (and c₁ c₂) f := (evalv c₁ (λ i hi, f i (by simp [hi, vars]))) &&
  (evalv c₂ (λ i hi, f i (by simp [hi, vars])))
| (or c₁ c₂) f := (evalv c₁ (λ i hi, f i (by simp [hi, vars]))) ||
  (evalv c₂ (λ i hi, f i (by simp [hi, vars])))
| (not c) f := bnot (evalv c (λ i hi, f i (by simp [hi, vars])))
| (xor c₁ c₂) f := bxor (evalv c₁ (λ i hi, f i (by simp [hi, vars])))
  (evalv c₂ (λ i hi, f i (by simp [hi, vars])))

lemma eval_eq_evalv [decidable_eq α] : ∀ (c : circuit α) (f : α → bool),
  eval c f = evalv c (λ x _, f x)
| true _ := rfl
| false _ := rfl
| (var x) f := rfl
| (and c₁ c₂) f := by rw [eval, evalv, eval_eq_evalv, eval_eq_evalv]
| (or c₁ c₂) f := by rw [eval, evalv, eval_eq_evalv, eval_eq_evalv]
| (not c) f := by rw [eval, evalv, eval_eq_evalv]
| (xor c₁ c₂) f := by rw [eval, evalv, eval_eq_evalv, eval_eq_evalv]

@[simp] def of_bool : bool → circuit α
| tt := true
| ff := false

instance : has_le (circuit α) :=
⟨λ c₁ c₂, ∀ f, eval c₁ f → eval c₂ f⟩

instance : preorder (circuit α) :=
{ le := (≤),
  le_refl := λ c f h, h,
  le_trans := λ c₁ c₂ c₃ h₁₂ h₂₃ f h₁, h₂₃ f (h₁₂ f h₁) }

lemma le_def : ∀ (c₁ c₂ : circuit α), c₁ ≤ c₂ ↔ ∀ f, eval c₁ f → eval c₂ f :=
λ _ _, iff.rfl

lemma exists_eval_iff_exists_evalv [decidable_eq α] (c : circuit α) :
  (∃ x, eval c x) ↔ ∃ x, evalv c x :=
begin
  split,
  { rintro ⟨x, hx⟩,
    use λ a _, x a,
    rw [eval_eq_evalv] at hx,
    exact hx },
  { rintro ⟨x, hx⟩,
    refine ⟨λ a, dite (a ∈ c.vars) (x a) (λ _, ff), _⟩,
    convert hx,
    rw [eval_eq_evalv],
    congr' 1,
    ext i hi,
    simp [hi] }
end

def simplify_and : circuit α → circuit α → circuit α
| true c := c
| c true := c
| false _ := false
| _ false := false
| c₁ c₂ := and c₁ c₂

@[simp] lemma eval_simplify_and : ∀ (c₁ c₂ : circuit α) (f : α → bool),
  eval (simplify_and c₁ c₂) f = (eval c₁ f) && (eval c₂ f) :=
begin
  intros c₁ c₂ f,
  cases c₁; cases c₂; simp [*, circuit.simplify_and, eval] at *
end

def simplify_or : circuit α → circuit α → circuit α
| true _ := true
| _ true := true
| false c := c
| c false := c
| c₁ c₂ := or c₁ c₂

@[simp] lemma eval_simplify_or : ∀ (c₁ c₂ : circuit α) (f : α → bool),
  eval (simplify_or c₁ c₂) f = (eval c₁ f) || (eval c₂ f) :=
begin
  intros c₁ c₂ f,
  cases c₁; cases c₂; simp [*, circuit.simplify_or, eval] at *
end

def simplify_not : circuit α → circuit α
| true := false
| false := true
| (not c) := c
| c := not c

@[simp] lemma eval_simplify_not : ∀ (c : circuit α) (f : α → bool),
  eval (simplify_not c) f = bnot (eval c f) :=
begin
  intros c f,
  cases c; simp [*, circuit.simplify_not, eval] at *
end

def simplify_xor : circuit α → circuit α → circuit α
| false c := c
| c false := c
| true c := not c
| c true := not c
| c₁ c₂ := xor c₁ c₂

lemma bnot_bxor : ∀ (b₁ b₂ : bool), bnot (bxor b₁ b₂) = bxor b₁ (bnot b₂) :=
dec_trivial

@[simp] lemma eval_simplify_xor : ∀ (c₁ c₂ : circuit α) (f : α → bool),
  eval (simplify_xor c₁ c₂) f = bxor (eval c₁ f) (eval c₂ f) :=
begin
  intros c₁ c₂ f,
  cases c₁; cases c₂; simp [*, circuit.simplify_xor, eval, bnot_bxor] at *,
end

def map : Π (c : circuit α) (f : α → β), circuit β
| true _ := true
| false _ := false
| (var x) f := var (f x)
| (and c₁ c₂) f := simplify_and (map c₁ f) (map c₂ f)
| (or c₁ c₂) f := simplify_or (map c₁ f) (map c₂ f)
| (not c) f := simplify_not (map c f)
| (xor c₁ c₂) f := simplify_xor (map c₁ f) (map c₂ f)

lemma eval_map {c : circuit α} {f : α → β} {g : β → bool} :
  eval (map c f) g = eval c (λ x, g (f x)) :=
begin
  induction c; simp [*, circuit.map, eval] at *
end

def simplify : Π (c : circuit α), circuit α
| true := true
| false := false
| (var x) := var x
| (and c₁ c₂) := simplify_and (simplify c₁) (simplify c₂)
| (or c₁ c₂) := simplify_or (simplify c₁) (simplify c₂)
| (not c) := simplify_not (simplify c)
| (xor c₁ c₂) := simplify_xor (simplify c₁) (simplify c₂)

@[simp] lemma eval_simplify : Π {c : circuit α} {f : α → bool},
  eval (simplify c) f = eval c f
| true _ := rfl
| false _ := rfl
| (var x) f := rfl
| (and c₁ c₂) f := by rw [simplify]; simp *
| (or c₁ c₂) f := by rw [simplify]; simp *
| (not c) f := by rw [simplify]; simp *
| (xor c₁ c₂) f := by rw [simplify]; simp *

def sum_vars_left [decidable_eq α] [decidable_eq β] : circuit (α ⊕ β) → list α
| true := []
| false := []
| (var (sum.inl x)) := [x]
| (var (sum.inr _)) := []
| (and c₁ c₂) := (sum_vars_left c₁ ++ sum_vars_left c₂).dedup
| (or c₁ c₂) := (sum_vars_left c₁ ++ sum_vars_left c₂).dedup
| (not c) := sum_vars_left c
| (xor c₁ c₂) := (sum_vars_left c₁ ++ sum_vars_left c₂).dedup

def sum_vars_right [decidable_eq α] [decidable_eq β] : circuit (α ⊕ β) → list β
| true := []
| false := []
| (var (sum.inl _)) := []
| (var (sum.inr x)) := [x]
| (and c₁ c₂) := (sum_vars_right c₁ ++ sum_vars_right c₂).dedup
| (or c₁ c₂) := (sum_vars_right c₁ ++ sum_vars_right c₂).dedup
| (not c) := sum_vars_right c
| (xor c₁ c₂) := (sum_vars_right c₁ ++ sum_vars_right c₂).dedup

lemma eval_eq_of_eq_on_vars [decidable_eq α] : Π {c : circuit α} {f g : α → bool}
  (h : ∀ x ∈ c.vars, f x = g x), eval c f = eval c g
| true _ _ _ := rfl
| false _ _ _ := rfl
| (var x) f g h := h x (by simp [vars])
| (and c₁ c₂) f g h :=
begin
  simp only [vars, list.mem_append, list.mem_dedup] at h,
  rw [eval, eval,
    eval_eq_of_eq_on_vars (λ x hx, h x (or.inl hx)),
    eval_eq_of_eq_on_vars (λ x hx, h x (or.inr hx))]
end
| (or c₁ c₂) f g h :=
begin
  simp only [vars, list.mem_append, list.mem_dedup] at h,
  rw [eval, eval,
    eval_eq_of_eq_on_vars (λ x hx, h x (or.inl hx)),
    eval_eq_of_eq_on_vars (λ x hx, h x (or.inr hx))]
end
| (not c) f g h :=
begin
  simp only [vars] at h,
  rw [eval, eval, eval_eq_of_eq_on_vars h]
end
| (xor c₁ c₂) f g h :=
begin
  simp only [vars, list.mem_append, list.mem_dedup] at h,
  rw [eval, eval,
    eval_eq_of_eq_on_vars (λ x hx, h x (or.inl hx)),
    eval_eq_of_eq_on_vars (λ x hx, h x (or.inr hx))]
end

@[simp] lemma mem_vars_iff_mem_sum_vars_left [decidable_eq α] [decidable_eq β] :
  Π {c : circuit (α ⊕ β)} {x : α},
  (x ∈ c.sum_vars_left) ↔ sum.inl x ∈ c.vars
| true _  := by simp [vars, sum_vars_left]
| false _  := by simp [vars, sum_vars_left]
| (var (sum.inl x)) _ := by simp [vars, sum_vars_left]
| (var (sum.inr _)) _ := by simp [vars, sum_vars_left]
| (and c₁ c₂) _ :=
  begin
    simp [vars, sum_vars_left],
    simp [mem_vars_iff_mem_sum_vars_left]
  end
| (or c₁ c₂) _ :=
  begin
    simp [vars, sum_vars_left],
    simp [mem_vars_iff_mem_sum_vars_left]
  end
| (not c) _ :=
  begin
    simp [vars, sum_vars_left],
    simp [mem_vars_iff_mem_sum_vars_left]
  end
| (xor c₁ c₂) _ :=
  begin
    simp [vars, sum_vars_left],
    simp [mem_vars_iff_mem_sum_vars_left]
  end

@[simp] lemma mem_vars_iff_mem_sum_vars_right [decidable_eq α] [decidable_eq β] :
  Π {c : circuit (α ⊕ β)} {x : β},
  (x ∈ c.sum_vars_right) ↔ sum.inr x ∈ c.vars
| true _  := by simp [vars, sum_vars_right]
| false _  := by simp [vars, sum_vars_right]
| (var (sum.inl _)) _ := by simp [vars, sum_vars_right]
| (var (sum.inr x)) _ := by simp [vars, sum_vars_right]
| (and c₁ c₂) _ :=
  begin
    simp [vars, sum_vars_right],
    simp [mem_vars_iff_mem_sum_vars_right]
  end
| (or c₁ c₂) _ :=
  begin
    simp [vars, sum_vars_right],
    simp [mem_vars_iff_mem_sum_vars_right]
  end
| (not c) _ :=
  begin
    simp [vars, sum_vars_right],
    simp [mem_vars_iff_mem_sum_vars_right]
  end
| (xor c₁ c₂) _ :=
  begin
    simp [vars, sum_vars_right],
    simp [mem_vars_iff_mem_sum_vars_right]
  end

lemma eval_eq_of_eq_on_sum_vars_left_right
  [decidable_eq α] [decidable_eq β] :
  Π {c : circuit (α ⊕ β)} {f g : α ⊕ β → bool}
  (h₁ : ∀ x ∈ c.sum_vars_left, f (sum.inl x) = g (sum.inl x))
  (h₂ : ∀ x ∈ c.sum_vars_right, f (sum.inr x) = g (sum.inr x)),
  eval c f = eval c g
| true _ _ _ _ := rfl
| false _ _ _ _ := rfl
| (var (sum.inl x)) f g h₁ h₂ := h₁ x (by simp [sum_vars_left])
| (var (sum.inr x)) f g h₁ h₂ := h₂ x (by simp [sum_vars_right])
| (and c₁ c₂) f g h₁ h₂ :=
begin
  simp only [sum_vars_left, sum_vars_right, list.mem_append, list.mem_dedup] at h₁ h₂,
  rw [eval, eval,
    eval_eq_of_eq_on_sum_vars_left_right
      (λ x hx, h₁ x (or.inl hx)) (λ x hx, h₂ x (or.inl hx)),
    eval_eq_of_eq_on_sum_vars_left_right
      (λ x hx, h₁ x (or.inr hx)) (λ x hx, h₂ x (or.inr hx))]
end
| (or c₁ c₂) f g h₁ h₂ :=
begin
  simp only [sum_vars_left, sum_vars_right, list.mem_append, list.mem_dedup] at h₁ h₂,
  rw [eval, eval,
    eval_eq_of_eq_on_sum_vars_left_right
      (λ x hx, h₁ x (or.inl hx)) (λ x hx, h₂ x (or.inl hx)),
    eval_eq_of_eq_on_sum_vars_left_right
      (λ x hx, h₁ x (or.inr hx)) (λ x hx, h₂ x (or.inr hx))]
end
| (not c) f g h₁ h₂ :=
begin
  simp only [sum_vars_left, sum_vars_right] at h₁ h₂,
  rw [eval, eval, eval_eq_of_eq_on_sum_vars_left_right h₁ h₂]
end
| (xor c₁ c₂) f g h₁ h₂ :=
begin
  simp only [sum_vars_left, sum_vars_right, list.mem_append, list.mem_dedup] at h₁ h₂,
  rw [eval, eval,
    eval_eq_of_eq_on_sum_vars_left_right
      (λ x hx, h₁ x (or.inl hx)) (λ x hx, h₂ x (or.inl hx)),
    eval_eq_of_eq_on_sum_vars_left_right
      (λ x hx, h₁ x (or.inr hx)) (λ x hx, h₂ x (or.inr hx))]
end

def bOr : Π (s : list α) (f : α → circuit β), circuit β
| [] _ := false
| (a::l) f := l.foldl (λ c x, simplify_or c (f x)) (f a)

@[simp] lemma eval_foldl_or :
  ∀ (s : list α) (f : α → circuit β) (c : circuit β) (g : β → bool),
    (eval (s.foldl (λ c x, simplify_or c (f x)) c) g : Prop) ↔
      eval c g ∨ (∃ a ∈ s, eval (f a) g)
| [] f c g := by simp [eval]; cases c.eval g; simp
| (a::l) f c g := begin
  rw [list.foldl_cons, eval_foldl_or],
  simp only [eval_simplify_or, bor_coe_iff, exists_prop, list.mem_cons_iff],
  split,
  { intro h,
    rcases h with (h₁ | h₂) | ⟨a, ha⟩,
    { simp * },
    { exact or.inr ⟨_, or.inl rfl, h₂⟩ },
    { exact or.inr ⟨_, or.inr ha.1, ha.2⟩ } },
  { intro h,
    rcases h with h | ⟨a, rfl| ha, h⟩,
    { simp * },
    { simp * },
    { exact or.inr ⟨_, ha, h⟩ } }
end

@[simp] lemma eval_bOr :
  ∀ {s : list α} {f : α → circuit β} {g : β → bool},
    eval (bOr s f) g ↔ ∃ a ∈ s, eval (f a) g
| [] _ _ := by simp [bOr, eval]
| [a] f g := by simp [bOr, eval]
| (a::l) f g :=
by rw [bOr, eval_foldl_or, list.exists_mem_cons_iff]

def bAnd : Π (s : list α) (f : α → circuit β), circuit β
| [] _ := true
| (a::l) f := l.foldl (λ c x, simplify_and c (f x)) (f a)

@[simp] lemma eval_foldl_and :
  ∀ (s : list α) (f : α → circuit β) (c : circuit β) (g : β → bool),
    (eval (s.foldl (λ c x, simplify_and c (f x)) c) g : Prop) ↔
      eval c g ∧ (∀ a ∈ s, eval (f a) g)
| [] f c g := by simp [eval]; cases c.eval g; simp
| (a::l) f c g := begin
  rw [list.foldl_cons, eval_foldl_and],
  simp only [eval_simplify_and, band_coe_iff, list.mem_cons_iff, forall_eq_or_imp],
  simp [and.assoc]
end

@[simp] lemma eval_bAnd :
  ∀ {s : list α} {f : α → circuit β} {g : β → bool},
    eval (bAnd s f) g ↔ ∀ a ∈ s, eval (f a) g
| [] _ _ := by simp [bAnd, eval]
| [a] f g := by simp [bAnd, eval]
| (a::l) f g :=
by rw [bAnd, eval_foldl_and]; simp

def assign_vars [decidable_eq α] :
  Π (c : circuit α) (f : Π (a : α) (ha : a ∈ c.vars), β ⊕ bool), circuit β
| true _ := true
| false _ := false
| (var x) f := sum.elim var (λ b : bool, if b then true else false) (f x (by simp [vars]))
| (and c₁ c₂) f := simplify_and (assign_vars c₁ (λ x hx, f x (by simp [hx, vars])))
                       (assign_vars c₂ (λ x hx, f x (by simp [hx, vars])))
| (or c₁ c₂) f := simplify_or (assign_vars c₁ (λ x hx, f x (by simp [hx, vars])))
                      (assign_vars c₂ (λ x hx, f x (by simp [hx, vars])))
| (not c) f := simplify_not (assign_vars c (λ x hx, f x (by simp [hx, vars])))
| (xor c₁ c₂) f := simplify_xor (assign_vars c₁ (λ x hx, f x (by simp [hx, vars])))
                        (assign_vars c₂ (λ x hx, f x (by simp [hx, vars])))

lemma eval_assign_vars [decidable_eq α] : ∀ {c : circuit α}
  {f : Π (a : α) (ha : a ∈ c.vars), β ⊕ bool} {g : β → bool},
  eval (assign_vars c f) g = evalv c (λ a ha,sum.elim g id (f a ha))
| true _ _ := rfl
| false _ _ := rfl
| (var x) f g := begin
  simp [assign_vars, eval, vars],
  cases f x (by simp [vars]),
  simp [eval],
  simp [eval],
  cases val; simp [eval]
end
| (and c₁ c₂) f g := begin
  simp [assign_vars, eval, vars],
  rw [eval_assign_vars, eval_assign_vars]
end
| (or c₁ c₂) f g := begin
  simp [assign_vars, eval, vars],
  rw [eval_assign_vars, eval_assign_vars]
end
| (not c) f g := begin
  simp [assign_vars, eval, vars],
  rw [eval_assign_vars]
end
| (xor c₁ c₂) f g := begin
  simp [assign_vars, eval, vars],
  rw [eval_assign_vars, eval_assign_vars]
end

def bind : Π (c : circuit α) (f : α → circuit β), circuit β
| true _ := true
| false _ := false
| (var x) f := f x
| (and c₁ c₂) f := simplify_and (bind c₁ f) (bind c₂ f)
| (or c₁ c₂) f := simplify_or (bind c₁ f) (bind c₂ f)
| (not c) f := simplify_not (bind c f)
| (xor c₁ c₂) f := simplify_xor (bind c₁ f) (bind c₂ f)

lemma eval_bind : ∀ (c : circuit α) (f : α → circuit β) (g : β → bool),
  eval (bind c f) g = eval c (λ a, eval (f a) g)
| true _ _ := rfl
| false _ _ := rfl
| (var x) f g := rfl
| (and c₁ c₂) f g := begin
  simp [bind, eval],
  rw [eval_bind, eval_bind]
end
| (or c₁ c₂) f g := begin
  simp [bind, eval],
  rw [eval_bind, eval_bind]
end
| (not c) f g := begin
  simp [bind, eval],
  rw [eval_bind]
end
| (xor c₁ c₂) f g := begin
  simp [bind, eval],
  rw [eval_bind, eval_bind]
end

def single [decidable_eq α] {s : list α} (x : Π a ∈ s, bool) : circuit α :=
bAnd s (λ i, if hi : i ∈ s then cond (x i hi) (var i) (not (var i)) else true)

@[simp] lemma eval_single [decidable_eq α] {s : list α} (x : Π a ∈ s, bool) (g : α → bool):
  eval (single x) g ↔ (∀ a ∈ s, g a = x a (by simpa)) :=
begin
  rw [single],
  simp,
  split,
  { intros h a ha,
    specialize h a ha,
    rw [dif_pos ha] at h,
    cases x a ha; simpa using h },
  { intros h a ha,
    rw [dif_pos ha],
    specialize h a ha,
    cases x a ha; simp [h] }
end

def nonempty_aux [decidable_eq α] :
  Π (c : circuit α), { b : bool // (∃ x, eval c x) = (b : Prop) }
| true := ⟨tt, by simp⟩
| false := ⟨ff, by simp⟩
| (var x) := ⟨tt, by simp⟩
-- | (or c₁ c₂) :=
-- let b₁ := nonempty_aux c₁ in
-- let b₂ := nonempty_aux c₂ in
-- ⟨b₁ || b₂, by
--   { simp only [exists_or_distrib, eval, bor_coe_iff, eq_iff_iff],
--     rw [← b₁.prop, ← b₂.prop] }⟩
-- | (and c₁ (or c₂ c₃)) :=
-- let b₁ := nonempty_aux (and c₁ c₂) in
-- let b₂ := nonempty_aux (and c₁ c₃) in
-- ⟨b₁ || b₂, by
--   { simp only [eval, bor_coe_iff, eq_iff_iff, band_coe_iff, and_or_distrib_left,
--       exists_or_distrib],
--     rw [← b₁.prop, ← b₂.prop],
--     simp }⟩
-- | (and (or c₁ c₂) c₃) :=
-- let b₁ := nonempty_aux (and c₁ c₃) in
-- let b₂ := nonempty_aux (and c₂ c₃) in
-- ⟨b₁ || b₂, by
--   { simp only [eval, bor_coe_iff, eq_iff_iff, band_coe_iff, or_and_distrib_right,
--       exists_or_distrib],
--     rw [← b₁.prop, ← b₂.prop],
--     simp }⟩
-- | (not (and c₁ c₂)) :=
-- let b₁ := nonempty_aux (not c₁) in
-- let b₂ := nonempty_aux (not c₂) in
-- ⟨b₁ || b₂, by
--   { simp only [eval, bor_coe_iff, eq_iff_iff, band_coe_iff, not_and_distrib, exists_or_distrib,
--     bool.bnot_iff_not, eq_ff_eq_not_eq_tt],
--     rw [← b₁.prop, ← b₂.prop],
--     simp }⟩
| c :=
let v := vars c in
have hv : vars c = v := rfl,
match v, hv with
| [], hv := ⟨eval c (λ _, ff), begin
    rw [exists_eval_iff_exists_evalv, eq_iff_iff, eval_eq_evalv],
    split,
    { rintros ⟨x, hx⟩,
      convert hx,
      ext i hi,
      rw [hv] at hi,
      exact false.elim hi },
    { intro h,
      use λ i _, ff,
      exact h }
  end⟩
| (i::l), hv :=
let c₁ := c.assign_vars (λ j _, if i = j then sum.inr tt else sum.inl j) in
let c₂ := c.assign_vars (λ j _, if i = j then sum.inr ff else sum.inl j) in
have h₁ : sizeof c₁ < sizeof c := sorry,
have h₂ : sizeof c₂ < sizeof c := sorry,
let b₁ := nonempty_aux c₁ in
let b₂ := nonempty_aux c₂ in
⟨b₁ || b₂, begin
  simp only [bor_coe_iff, eq_iff_iff, eval_eq_evalv],
  rw [← b₁.prop, ← b₂.prop],
  simp only [eval_assign_vars],
  split,
  { rintro ⟨x, hx⟩,
    cases hi : x i,
    { right,
      use x,
      convert hx,
      ext j hj,
      split_ifs,
      { subst h,
        simp [hi] },
      { simp } },
    { left,
      use x,
      convert hx,
      ext j hj,
      split_ifs,
      { subst h,
        simp [hi] },
      { simp } } },
  { intro h,
    rcases h with ⟨x, hx⟩ | ⟨x, hx⟩,
    { refine ⟨_, hx⟩ },
    { refine ⟨_, hx⟩ } }
end⟩
end

def nonempty [decidable_eq α] (c : circuit α) : bool :=
(nonempty_aux c).1

lemma nonempty_iff [decidable_eq α] (c : circuit α) :
  nonempty c ↔ ∃ x, eval c x :=
by rw [nonempty, ← (nonempty_aux c).2]

def always_true [decidable_eq α] (c : circuit α) : bool :=
bnot (nonempty (not c))

lemma always_true_iff [decidable_eq α] (c : circuit α) :
  always_true c ↔ ∀ x, eval c x :=
by simp [always_true, nonempty_iff, not_not]

instance [decidable_eq α] : decidable_rel ((≤) : circuit α → circuit α → Prop) :=
λ c₁ c₂, decidable_of_iff (always_true ((not c₁).or c₂))
  begin simp [always_true_iff, le_def, or_iff_not_imp_left], end

end circuit


import soundness.soundnessCLC
import completeness.canonical
import completeness.closureC
-- import syntax.axiomsCLC
import syntax.consistency_lemmas
-- import syntax.CLClemmas
-- import tactic.induction
-- import data.finset.powerset

local attribute [instance] classical.prop_decidable

open set formCLC

namespace canonical

----------------------------------------------------------
-- Canonical CL Model (not a valid CLC model)
----------------------------------------------------------
@[simps?] noncomputable def canonical_model_CLC (agents : Type) [hN : fintype agents] [ha : nonempty agents] :
  modelCLK agents :=
{ f := canonical_CLK ha (formCLC agents) (nprfalseCLC ha),
  -- V is as usual, such that s ∈ V (p) iff p ∈ s
  v := λ  n, {s | (formCLC.var n) ∈ s.1} }

/-- Allows us to write `φ ∈ s` instead of `φ ∈ s.val` -/
instance states.set_like {agents : Type} [hN : fintype agents] [ha : nonempty agents] :
  set_like (canonical_model_CLC agents).1.states (formCLC agents) :=
{ coe := λ s, s.1,
  coe_injective' := subtype.coe_injective }

@[simp] lemma states.val_eq_coe {agents : Type} [hN : fintype agents] [ha : nonempty agents]
  (s : (canonical_model_CLC agents).1.states) : s.1 = s := rfl

  @[simp] lemma set_like.set_of_mem {S A : Type*} [h : set_like S A] (s : S) : {x | x ∈ s} = s := rfl

----------------------------------------------------------
-- Filtering S
----------------------------------------------------------
-- Definitions about Sf
----------------------------------------------------------
def S_f {agents : Type} [hN : fintype agents] [ha : nonempty agents] (φ : formCLC agents) : Type :=
finset.attach (finset.filter (λ sf, ∃ s: (canonical_model_CLC agents).f.states, (s.1 ∩ {x | x ∈ cl(φ)}) = {x | x ∈ sf}) (finset.powerset (cl(φ))))

instance {agents : Type} [hN : fintype agents] [ha : nonempty agents] (φ : formCLC agents) :
  set_like (S_f φ) (formCLC agents) :=
{ coe := λ sf, sf.1.1,
  coe_injective' := λ x y h, subtype.coe_injective (subtype.coe_injective (by simpa using h)) }

@[simp] lemma coe_eq_coe_coe_val {agents : Type} [hN : fintype agents] {ha : nonempty agents} {φ : formCLC agents}
  (sf : S_f φ) : (sf : set (formCLC agents)) = (sf.1 : finset (formCLC agents)) :=
rfl

@[simp] lemma mem_mk {agents : Type} [hN : fintype agents] [ha : nonempty agents] {φ : formCLC agents}
  {x : formCLC agents} {s} (hs₁ hs₂) : @has_mem.mem _ (S_f φ) _ x ⟨⟨s, hs₁⟩, hs₂⟩ ↔ x ∈ s :=
iff.rfl

-- get sf from s
noncomputable def s_f {agents : Type} [hN : fintype agents] [ha : nonempty agents]
  (φ : formCLC agents) (s : (canonical_model_CLC agents).f.states) :
  (S_f φ) :=
begin
  fconstructor,
  fconstructor,
  exact finset.filter (λ ψ, ψ ∈ s) (cl(φ)),
  simp,
  apply exists.intro s,
  exact s.1.inter_comm ↑(cl φ),
  simp,
end

def s_to_s_f {agents : Type} [hN : fintype agents] [ha : nonempty agents]
  (φ : formCLC agents) (s : (canonical_model_CLC agents).f.states) :
  ∃ sf : (S_f φ), ∀ {x}, x ∈ sf ↔ x ∈ s.1 ∧ x ∈ cl φ  :=
begin
  fconstructor,
  fconstructor,
  fconstructor,
  { exact finset.filter (λ ψ, ψ ∈ s) (cl(φ)), },
  { simp,
    apply exists.intro s,
    exact s.1.inter_comm ↑(cl φ), },
  { simp, },
  { intro x,
    simp,
    exact and.comm, },
end

/-
-- for each sf, there exists some s which filters to sf
def s_f_to_s {agents : Type} [ha : nonempty agents] [hN : fintype agents] (φ : formCLC agents)
  (sf : (S_f φ)) :
  ∃ s: (canonical_model_CLC agents).f.states, (s.1 ∩ {x | x ∈ cl(φ)}) = {x | x ∈ sf.1.1} :=
begin
  cases sf.1 with sfin hsf,
  dsimp[finset.powerset, finset.filter] at *,
  simp at *,
  exact hsf.right,
end
-/

-- for each sf, there exists some s which filters to sf
def s_f_to_s {agents : Type} [ha : nonempty agents] [hN : fintype agents] (φ : formCLC agents)
  (sf : (S_f φ)) :
  ∃ s: (canonical_model_CLC agents).f.states, ∀ {x}, x ∈ sf ↔ x ∈ s.1 ∧ x ∈ cl φ :=
begin
  rcases sf with ⟨⟨sfin, hsf₁⟩, hsf₂⟩,
  rcases finset.mem_filter.mp hsf₁ with ⟨hsf₁₁, s, hs⟩,
  use s,
  simpa [set.ext_iff, iff.comm] using hs
end

-- -- for each sf, there exists some s which filters to sf
-- def s_f_s_iff {agents : Type} [ha : nonempty agents] [hN : fintype agents] (φ : formCLC agents)
--   (sf : (S_f φ)) (s : (canonical_model_CLC agents).f.states) (h : ∀ {x}, x ∈ sf ↔ x ∈ s.1 ∧ x ∈ cl φ):
--   ∃ s: (canonical_model_CLC agents).f.states, ∀ {x}, x ∈ sf ↔ x ∈ s.1 ∧ x ∈ cl φ :=
-- begin
--   rcases sf with ⟨⟨sfin, hsf₁⟩, hsf₂⟩,
--   rcases finset.mem_filter.mp hsf₁ with ⟨hsf₁₁, s, hs⟩,
--   use s,
--   simpa [set.ext_iff, iff.comm] using hs
-- end

-- Lemmas about Sf
----------------------------------------------------------
-- Sf is  finite
noncomputable instance fin_S_f {agents : Type} [hN : fintype agents] [ha : nonempty agents]
  (φ : formCLC agents) :
  fintype (S_f φ) :=  additive.fintype

-- Sf is not empty
instance nonempty_S_f {agents : Type} [hN : fintype agents] [ha : nonempty agents]
  (φ : formCLC agents) :
  nonempty (S_f φ) :=
begin
  -- simp[S_f, finset.filter],
  have hs := (canonical_model_CLC agents).f.hs,
  cases hs with s,
  have sf := s_f φ s,
  exact nonempty.intro sf,
end

-- sf ⊆ s
lemma s_f_subset_s {agents : Type} [ha : nonempty agents] [hN : fintype agents]
  (φ : formCLC agents) (s : (canonical_model_CLC agents).f.states) :
  {x | x ∈ (s_f φ s)} ⊆ s :=
begin
  simp[s_f],
  apply inter_subset_right,
end

-- sf ⊆ cl φ
lemma s_f_subset_cl {agents : Type} [ha : nonempty agents] [hN : fintype agents]
  (φ : formCLC agents) (sf : (S_f φ)) :
  (sf.1 : finset (formCLC agents)) ⊆ cl φ :=
begin
  cases sf,
  cases sf_val,
  dsimp at *,
  simp[finset.has_mem] at *,
  simp[←finset.val_inj] at *,
  exact sf_val_property.left,
end

-- all sf are consistent
lemma s_f_ax {agents : Type} [ha : nonempty agents] [hN : fintype agents]
  (φ : formCLC agents) (sf : (S_f φ)) :
  ax_consistent {x | x ∈ sf} :=
begin
  cases (s_f_to_s φ sf) with s hs,
  have hax := s.2.1,
  simp [ax_consistent] at *,
  intros fs hsfin,
  apply hax fs,
  intros ψ hψfs,
  have hsfs : ∀ x ∈ sf, x ∈ s, from
  begin
    intros x hx,
    rw hs at hx,
    exact hx.1,
  end,
  apply hsfs,
  apply hsfin,
  exact hψfs,
end

-- sf = tf iff they have the same finset
lemma s_f_eq {agents : Type} [ha : nonempty agents] [hN : fintype agents]
  (φ : formCLC agents) {sf tf : (S_f φ)} :
  sf = tf ↔ sf.1.1 = tf.1.1 :=
begin
  split,
   repeat
   { intro h,
    cases sf, cases tf,
    cases sf_val, cases tf_val,
    simp at *,
    exact h, },
end

lemma s_f_to_s_to_s_f {agents : Type} [ha : nonempty agents] [hN : fintype agents] {φ : formCLC agents}
  {sf : (S_f φ)} {s : (canonical_model_CLC agents).f.states} (hs : ∀ {x}, x ∈ sf ↔ (x ∈ s.1 ∧ x ∈ cl φ)) :
    (s_f φ s) = sf :=
begin
  rw s_f_eq,
  unfold s_f,
  ext1 x,
  split,
  { intro h,
    apply hs.mpr,
    rw finset.mem_filter at h,
    rw and.comm,
    exact h, },
  { intro h,
    rw [finset.mem_filter, and.comm],
    apply hs.mp,
    exact h, },
end

-- ψ ∈ s → ψ ∈ cl(φ) → ψ ∈ sf
lemma s_f_contains {agents : Type} [ha : nonempty agents] [hN : fintype agents]
  (φ ψ : formCLC agents) (sf : (S_f φ)) (s : (canonical_model_CLC agents).f.states)
  (hs : ∀ {x}, x ∈ sf ↔ x ∈ s ∧ x ∈ cl φ) :
  ψ ∈ s → ψ ∈ cl(φ) → ψ ∈ sf :=
begin
  intros h1 h2,
  exact hs.mpr ⟨h1, h2⟩
end

-- (ψ ∉ s) ∨ (ψ ∉ cl(φ)) → ψ ∉ sf
lemma s_f_n_contains {agents : Type} [ha : nonempty agents] [hN : fintype agents]
  (φ ψ : formCLC agents) (sf : (S_f φ)) (s : (canonical_model_CLC agents).f.states)
  (hs : ∀ {x}, x ∈ sf ↔ x ∈ s ∧ x ∈ cl φ) :
  (ψ ∉ s ∨ ψ ∉ cl(φ)) → ψ ∉ sf :=
begin
  intro h1,
  rwa [hs, not_and_distrib]
end

-- ψ ∈ cl φ ⇒ ((∀ sf, ψ ∉ sf) ⇔ (⊢ ψ ↔ ⊥))
lemma S_f_empty_iff_false_sf {agents : Type} [hN : fintype agents] [ha : nonempty agents]
  {φ ψ : formCLC agents} (hψ : ψ ∈ cl φ) (hempty : {sf : (S_f φ) | ψ ∈ sf} = ∅) :
  axCLC (ψ ↔' ⊥) :=
begin
  apply @set_empty_iff_false (formCLC agents),
  rw subset_empty_iff,
  rw eq_empty_iff_forall_not_mem at *,
  intros s hf,
  have hsf := s_to_s_f φ s,
  cases hsf with sf hsf,
  apply hempty sf (hsf.mpr (and.intro hf hψ)),
end

-- x ∉ sf ⇒ ∃ y ∈ sf, ⊢ (y ↔ ¬ x)
lemma s_f_closed {agents : Type} [hN : fintype agents] [ha : nonempty agents]
  {φ x : formCLC agents} {sf : (S_f φ)} (hnf : x ∉ sf) (hx : x ∈ cl φ)  :
  ∃ y, y ∈ sf ∧ axCLC (y <~> ¬ x) :=
begin
  -- χ ∉ t, from 5, by definition Sf , because χ ∈ cl(φ).
  have hs := s_f_to_s φ sf, cases hs with s hs, simp at hs,
  have hn : x ∉ s, from
  begin
      by_contradiction hf,
      apply hnf,
      exact hs.mpr ⟨hf, hx⟩,
  end,
  -- ¬χ ∈ t, from hn, because s and t are maximally consistent.
  have hnx : ((¬' x) ∈ s.1) := not_in_from_notin s.2 hn,
  -- ∃ψ, (ψ ↔ ¬χ) ∧ (ψ ∈ cl(φ)), because cl is closed under single negations.
  have hy := cl_closed_single_neg φ x hx,
  cases hy with y hy,
  -- ψ ∈ s ∨ ψ ∈ t, from hnx & hy, because s and t are maximally consistent.
  have hst : y ∈ s, from
  begin
    apply max_ax_contains_by_set_proof s.2 hnx,
    apply @iff_r (formCLC agents) _ _,
    exact hy.2,
  end,
  -- ψ ∈ sf ∨ ψ ∈ tf , from hst & hy, by definition Sf .
  have hst : y ∈ sf := hs.mpr ⟨hst, hy.1⟩,
  apply exists.intro y,
  split,
  exact hst,
  exact hy.right,
end

@[simp] lemma set_of_S_f {agents : Type} [ha : nonempty agents] [hN : fintype agents]
  {φ ψ : formCLC agents} (sf : S_f φ) :
  sf ∈ {sf : S_f φ | ψ ∈ sf} ↔ (ψ ∈ sf) := mem_set_of

end canonical


import Lean4Axiomatic.Integer

/-! # Rational numbers: fundamental definitions and properties -/

namespace Lean4Axiomatic.Rational

open Logic (AP)

/-- Operations pertaining to rational number equivalence. -/
class Equivalence.Ops (ℚ : Type) :=
  /-- Equivalence relation; holds if the inputs have the same numeric value. -/
  eqv : ℚ → ℚ → Prop

export Equivalence.Ops (eqv)

/-- Enables the use of the `· ≃ ·` operator for equivalence. -/
instance eqv_tilde_dash_inst
    {ℚ : Type} [Equivalence.Ops ℚ] : Operators.TildeDash ℚ
    := {
  tildeDash := eqv
}

/-- Properties of rational number equivalence. -/
class Equivalence.Props (ℚ : Type) [Ops ℚ] :=
  /-- Equivalence is reflexive. -/
  eqv_refl {p : ℚ} : p ≃ p

  /-- Equivalence is symmetric. -/
  eqv_symm {p q : ℚ} : p ≃ q → q ≃ p

  /-- Equivalence is transitive. -/
  eqv_trans {p q r : ℚ} : p ≃ q → q ≃ r → p ≃ r

export Equivalence.Props (eqv_refl eqv_symm eqv_trans)

/-- All rational number equivalence axioms. -/
class Equivalence (ℚ : Type) extends Equivalence.Ops ℚ, Equivalence.Props ℚ

/--
Rational number equivalence is an equivalence relation.

This enables it to be used in generic contexts; for example, as a relation in
`calc` expressions.
-/
instance eqv_op_inst
    {ℚ : Type} [Equivalence ℚ] : Relation.Equivalence.EqvOp ℚ
    := {
  refl := eqv_refl
  symm := eqv_symm
  trans := eqv_trans
}

/--
Operations pertaining to the conversion of rational numbers into and out of
other types.
-/
class Conversion.Ops
    {ℕ ℤ : outParam Type} [Natural ℕ] [Integer (ℕ := ℕ) ℤ] (ℚ : Type)
    :=
  /-- Converts an integer into its equivalent rational number value. -/
  from_integer : ℤ → ℚ

export Conversion.Ops (from_integer)

/-- Enables the use of implicit coercions from integers to rationals. -/
instance coe_from_integer_inst
    {ℕ ℤ : Type} [Natural ℕ] [Integer (ℕ := ℕ) ℤ]
    {ℚ : Type} [Conversion.Ops (ℤ := ℤ) ℚ] : Coe ℤ ℚ
    := {
  coe := from_integer
}

/-- Natural number literals can be converted into rational numbers. -/
instance of_nat_inst
    {ℕ ℤ : Type} [Natural ℕ] [Integer (ℕ := ℕ) ℤ]
    {ℚ : Type} [Conversion.Ops (ℤ := ℤ) ℚ] {n : Nat} : OfNat ℚ n
    := {
  ofNat := ((OfNat.ofNat n : ℤ) : ℚ)
}

/-- Properties of rational number conversion. -/
class Conversion.Props
    {ℕ ℤ : outParam Type} [Natural ℕ] [Integer (ℕ := ℕ) ℤ]
    (ℚ : Type) [Equivalence.Ops ℚ] [Ops (ℤ := ℤ) ℚ]
    :=
  /-- Equivalent integers are converted to equivalent rationals. -/
  from_integer_subst {a₁ a₂ : ℤ} : a₁ ≃ a₂ → (a₁ : ℚ) ≃ (a₂ : ℚ)

  /-- Equivalent converted rationals came from the same integer. -/
  from_integer_inject {a₁ a₂ : ℤ} : (a₁ : ℚ) ≃ (a₂ : ℚ) → a₁ ≃ a₂

export Conversion.Props (from_integer_inject from_integer_subst)

/-- All rational number conversion axioms. -/
class Conversion
    {ℕ ℤ : outParam Type} [Natural ℕ] [Integer (ℕ := ℕ) ℤ]
    (ℚ : Type) [Equivalence.Ops ℚ]
    :=
  toOps : Conversion.Ops (ℤ := ℤ) ℚ
  toProps : Conversion.Props ℚ

attribute [instance] Conversion.toOps
attribute [instance] Conversion.toProps

/-- All fundamental rational number axioms. -/
class Core {ℕ ℤ : outParam Type} [Natural ℕ] [Integer (ℕ := ℕ) ℤ] (ℚ : Type) :=
  toEquivalence : Equivalence ℚ
  toConversion : Conversion (ℤ := ℤ) ℚ

attribute [instance] Core.toConversion
attribute [instance] Core.toEquivalence

variable {ℕ ℤ : Type} [Natural ℕ] [Integer (ℕ := ℕ) ℤ]
variable {ℚ : Type} [Core (ℤ := ℤ) ℚ]

/--
If `Integer.Nonzero` holds for an integer, then `· ≄ 0` holds for its rational
equivalent.

**Property intuition**: Since the integers are embedded in the rationals, we
expect that integer properties hold for their embedded versions.

**Proof intuition**: We assume `(a : ℚ) ≃ 0` because we are trying to show its
negation. This implies that `a ≃ 0` (as an integer), but this contradicts the
`Integer.Nonzero` assumption.
-/
theorem from_integer_preserves_nonzero
    {a : ℤ} : Integer.Nonzero a → (a : ℚ) ≄ 0
    := by
  intro (_ : Integer.Nonzero a) (_ : (a : ℚ) ≃ 0)
  show False
  have : a ≄ 0 := Integer.nonzero_iff_neqv_zero.mp ‹Integer.Nonzero a›
  have : (a : ℚ) ≃ (0 : ℚ) := ‹(a : ℚ) ≃ 0›
  have : a ≃ 0 := from_integer_inject this
  exact absurd ‹a ≃ 0› ‹a ≄ 0›

/-- Make `from_integer_preserves_nonzero` available for instance search. -/
instance from_integer_preserves_nonzero_inst
    {a : ℤ} [Integer.Nonzero a] : AP ((a : ℚ) ≄ 0)
    :=
  AP.mk (from_integer_preserves_nonzero ‹Integer.Nonzero a›)

/--
One and zero are distinct rational numbers.

**Intuition**: They are also distinct integers, and their rational number
equivalents obey the same properties.
-/
theorem nonzero_one : (1 : ℚ) ≄ 0 := from_integer_preserves_nonzero_inst.ev

/--
For some reason Lean's instance search won't derive this from
`from_integer_preserves_nonzero_inst`, so we need it defined explicitly.
-/
instance nonzero_one_inst : AP ((1 : ℚ) ≄ 0) := AP.mk nonzero_one

end Lean4Axiomatic.Rational


/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.analysis.calculus.mean_value
import Mathlib.tactic.monotonicity.default
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Extending differentiability to the boundary

We investigate how differentiable functions inside a set extend to differentiable functions
on the boundary. For this, it suffices that the function and its derivative admit limits there.
A general version of this statement is given in `has_fderiv_at_boundary_of_tendsto_fderiv`.

One-dimensional versions, in which one wants to obtain differentiability at the left endpoint or
the right endpoint of an interval, are given in
`has_deriv_at_interval_left_endpoint_of_tendsto_deriv` and
`has_deriv_at_interval_right_endpoint_of_tendsto_deriv`. These versions are formulated in terms
of the one-dimensional derivative `deriv ℝ f`.
-/

/-- If a function `f` is differentiable in a convex open set and continuous on its closure, and its
derivative converges to a limit `f'` at a point on the boundary, then `f` is differentiable there
with derivative `f'`. -/
theorem has_fderiv_at_boundary_of_tendsto_fderiv {E : Type u_1} [normed_group E] [normed_space ℝ E] {F : Type u_2} [normed_group F] [normed_space ℝ F] {f : E → F} {s : set E} {x : E} {f' : continuous_linear_map ℝ E F} (f_diff : differentiable_on ℝ f s) (s_conv : convex s) (s_open : is_open s) (f_cont : ∀ (y : E), y ∈ closure s → continuous_within_at f s y) (h : filter.tendsto (fun (y : E) => fderiv ℝ f y) (nhds_within x s) (nhds f')) : has_fderiv_within_at f f' (closure s) x := sorry

/-- If a function is differentiable on the right of a point `a : ℝ`, continuous at `a`, and
its derivative also converges at `a`, then `f` is differentiable on the right at `a`. -/
theorem has_deriv_at_interval_left_endpoint_of_tendsto_deriv {E : Type u_1} [normed_group E] [normed_space ℝ E] {s : set ℝ} {e : E} {a : ℝ} {f : ℝ → E} (f_diff : differentiable_on ℝ f s) (f_lim : continuous_within_at f s a) (hs : s ∈ nhds_within a (set.Ioi a)) (f_lim' : filter.tendsto (fun (x : ℝ) => deriv f x) (nhds_within a (set.Ioi a)) (nhds e)) : has_deriv_within_at f e (set.Ici a) a := sorry

/-- If a function is differentiable on the left of a point `a : ℝ`, continuous at `a`, and
its derivative also converges at `a`, then `f` is differentiable on the left at `a`. -/
theorem has_deriv_at_interval_right_endpoint_of_tendsto_deriv {E : Type u_1} [normed_group E] [normed_space ℝ E] {s : set ℝ} {e : E} {a : ℝ} {f : ℝ → E} (f_diff : differentiable_on ℝ f s) (f_lim : continuous_within_at f s a) (hs : s ∈ nhds_within a (set.Iio a)) (f_lim' : filter.tendsto (fun (x : ℝ) => deriv f x) (nhds_within a (set.Iio a)) (nhds e)) : has_deriv_within_at f e (set.Iic a) a := sorry

/-- If a real function `f` has a derivative `g` everywhere but at a point, and `f` and `g` are
continuous at this point, then `g` is also the derivative of `f` at this point. -/
theorem has_deriv_at_of_has_deriv_at_of_ne {E : Type u_1} [normed_group E] [normed_space ℝ E] {f : ℝ → E} {g : ℝ → E} {x : ℝ} (f_diff : ∀ (y : ℝ), y ≠ x → has_deriv_at f (g y) y) (hf : continuous_at f x) (hg : continuous_at g x) : has_deriv_at f (g x) x := sorry


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Floris van Doorn
-/
import algebra.bounds
import algebra.order.archimedean
import algebra.star.basic
import data.real.cau_seq_completion

/-!
# Real numbers from Cauchy sequences

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file defines `ℝ` as the type of equivalence classes of Cauchy sequences of rational numbers.
This choice is motivated by how easy it is to prove that `ℝ` is a commutative ring, by simply
lifting everything to `ℚ`.
-/

assert_not_exists finset
assert_not_exists module
assert_not_exists submonoid

open_locale pointwise

/-- The type `ℝ` of real numbers constructed as equivalence classes of Cauchy sequences of rational
numbers. -/
structure real := of_cauchy ::
(cauchy : cau_seq.completion.Cauchy (abs : ℚ → ℚ))
notation `ℝ` := real

attribute [pp_using_anonymous_constructor] real

namespace cau_seq.completion

-- this can't go in `data.real.cau_seq_completion` as the structure on `rat` isn't available
@[simp] theorem of_rat_rat {abv : ℚ → ℚ} [is_absolute_value abv] (q : ℚ) :
  of_rat (q : ℚ) = (q : @Cauchy _ _ _ _ abv _) := rfl

end cau_seq.completion

namespace real
open cau_seq cau_seq.completion

variables {x y : ℝ}

lemma ext_cauchy_iff : ∀ {x y : real}, x = y ↔ x.cauchy = y.cauchy
| ⟨a⟩ ⟨b⟩ := by split; cc

lemma ext_cauchy {x y : real} : x.cauchy = y.cauchy → x = y :=
ext_cauchy_iff.2

/-- The real numbers are isomorphic to the quotient of Cauchy sequences on the rationals. -/
def equiv_Cauchy : ℝ ≃ cau_seq.completion.Cauchy abs :=
⟨real.cauchy, real.of_cauchy, λ ⟨_⟩, rfl, λ _, rfl⟩

-- irreducible doesn't work for instances: https://github.com/leanprover-community/lean/issues/511
@[irreducible] private def zero : ℝ := ⟨0⟩
@[irreducible] private def one : ℝ := ⟨1⟩
@[irreducible] private def add : ℝ → ℝ → ℝ | ⟨a⟩ ⟨b⟩ := ⟨a + b⟩
@[irreducible] private def neg : ℝ → ℝ | ⟨a⟩ := ⟨-a⟩
@[irreducible] private def mul : ℝ → ℝ → ℝ | ⟨a⟩ ⟨b⟩ := ⟨a * b⟩
@[irreducible] private noncomputable def inv' : ℝ → ℝ | ⟨a⟩ := ⟨a⁻¹⟩

instance : has_zero ℝ := ⟨zero⟩
instance : has_one ℝ := ⟨one⟩
instance : has_add ℝ := ⟨add⟩
instance : has_neg ℝ := ⟨neg⟩
instance : has_mul ℝ := ⟨mul⟩
instance : has_sub ℝ := ⟨λ a b, a + (-b)⟩
noncomputable instance : has_inv ℝ := ⟨inv'⟩

lemma of_cauchy_zero : (⟨0⟩ : ℝ) = 0 := show _ = zero, by rw zero
lemma of_cauchy_one : (⟨1⟩ : ℝ) = 1 := show _ = one, by rw one
lemma of_cauchy_add (a b) : (⟨a + b⟩ : ℝ) = ⟨a⟩ + ⟨b⟩ := show _ = add _ _, by rw add
lemma of_cauchy_neg (a) : (⟨-a⟩ : ℝ) = -⟨a⟩ := show _ = neg _, by rw neg
lemma of_cauchy_sub (a b) : (⟨a - b⟩ : ℝ) = ⟨a⟩ - ⟨b⟩ :=
by { rw [sub_eq_add_neg, of_cauchy_add, of_cauchy_neg], refl }
lemma of_cauchy_mul (a b) : (⟨a * b⟩ : ℝ) = ⟨a⟩ * ⟨b⟩ := show _ = mul _ _, by rw mul
lemma of_cauchy_inv {f} : (⟨f⁻¹⟩ : ℝ) = ⟨f⟩⁻¹ := show _ = inv' _, by rw inv'

lemma cauchy_zero : (0 : ℝ).cauchy = 0 := show zero.cauchy = 0, by rw zero
lemma cauchy_one : (1 : ℝ).cauchy = 1 := show one.cauchy = 1, by rw one
lemma cauchy_add : ∀ a b, (a + b : ℝ).cauchy = a.cauchy + b.cauchy
| ⟨a⟩ ⟨b⟩ := show (add _ _).cauchy = _, by rw add
lemma cauchy_neg : ∀ a, (-a : ℝ).cauchy = -a.cauchy
| ⟨a⟩ := show (neg _).cauchy = _, by rw neg
lemma cauchy_mul : ∀ a b, (a * b : ℝ).cauchy = a.cauchy * b.cauchy
| ⟨a⟩ ⟨b⟩ := show (mul _ _).cauchy = _, by rw mul
lemma cauchy_sub : ∀ a b, (a - b : ℝ).cauchy = a.cauchy - b.cauchy
| ⟨a⟩ ⟨b⟩ := by { rw [sub_eq_add_neg, ←cauchy_neg, ←cauchy_add], refl }
lemma cauchy_inv : ∀ f, (f⁻¹ : ℝ).cauchy = f.cauchy⁻¹
| ⟨f⟩ := show (inv' _).cauchy = _, by rw inv'

instance : has_nat_cast ℝ := { nat_cast := λ n, ⟨n⟩ }
instance : has_int_cast ℝ := { int_cast := λ z, ⟨z⟩ }
instance : has_rat_cast ℝ := { rat_cast := λ q, ⟨q⟩ }

lemma of_cauchy_nat_cast (n : ℕ) : (⟨n⟩ : ℝ) = n := rfl
lemma of_cauchy_int_cast (z : ℤ) : (⟨z⟩ : ℝ) = z := rfl
lemma of_cauchy_rat_cast (q : ℚ) : (⟨q⟩ : ℝ) = q := rfl

lemma cauchy_nat_cast (n : ℕ) : (n : ℝ).cauchy = n := rfl
lemma cauchy_int_cast (z : ℤ) : (z : ℝ).cauchy = z := rfl
lemma cauchy_rat_cast (q : ℚ) : (q : ℝ).cauchy = q := rfl

instance : comm_ring ℝ :=
begin
  refine_struct { zero  := (0 : ℝ),
                  one   := (1 : ℝ),
                  mul   := (*),
                  add   := (+),
                  neg   := @has_neg.neg ℝ _,
                  sub   := @has_sub.sub ℝ _,
                  npow  := @npow_rec ℝ ⟨1⟩ ⟨(*)⟩,
                  nsmul := @nsmul_rec ℝ ⟨0⟩ ⟨(+)⟩,
                  zsmul := @zsmul_rec ℝ ⟨0⟩ ⟨(+)⟩ ⟨@has_neg.neg ℝ _⟩,
                  ..real.has_nat_cast,
                  ..real.has_int_cast, };
  repeat { rintro ⟨_⟩, };
  try { refl };
  simp [← of_cauchy_zero, ← of_cauchy_one, ←of_cauchy_add, ←of_cauchy_neg, ←of_cauchy_mul,
    λ n, show @coe ℕ ℝ ⟨_⟩ n = ⟨n⟩, from rfl, has_nat_cast.nat_cast, has_int_cast.int_cast];
  apply add_assoc <|> apply add_comm <|> apply mul_assoc <|> apply mul_comm <|>
    apply left_distrib <|> apply right_distrib <|> apply sub_eq_add_neg <|> skip,
end

/-- `real.equiv_Cauchy` as a ring equivalence. -/
@[simps]
def ring_equiv_Cauchy : ℝ ≃+* cau_seq.completion.Cauchy abs :=
{ to_fun := cauchy,
  inv_fun := of_cauchy,
  map_add' := cauchy_add,
  map_mul' := cauchy_mul,
  ..equiv_Cauchy }

/-! Extra instances to short-circuit type class resolution.

 These short-circuits have an additional property of ensuring that a computable path is found; if
 `field ℝ` is found first, then decaying it to these typeclasses would result in a `noncomputable`
 version of them. -/
instance : ring ℝ               := by apply_instance
instance : comm_semiring ℝ      := by apply_instance
instance : semiring ℝ           := by apply_instance
instance : comm_monoid_with_zero ℝ := by apply_instance
instance : monoid_with_zero ℝ   := by apply_instance
instance : add_comm_group ℝ     := by apply_instance
instance : add_group ℝ          := by apply_instance
instance : add_comm_monoid ℝ    := by apply_instance
instance : add_monoid ℝ         := by apply_instance
instance : add_left_cancel_semigroup ℝ := by apply_instance
instance : add_right_cancel_semigroup ℝ := by apply_instance
instance : add_comm_semigroup ℝ := by apply_instance
instance : add_semigroup ℝ      := by apply_instance
instance : comm_monoid ℝ        := by apply_instance
instance : monoid ℝ             := by apply_instance
instance : comm_semigroup ℝ     := by apply_instance
instance : semigroup ℝ          := by apply_instance
instance : inhabited ℝ          := ⟨0⟩

/-- The real numbers are a `*`-ring, with the trivial `*`-structure. -/
instance : star_ring ℝ          := star_ring_of_comm
instance : has_trivial_star ℝ   := ⟨λ _, rfl⟩

/-- Make a real number from a Cauchy sequence of rationals (by taking the equivalence class). -/
def mk (x : cau_seq ℚ abs) : ℝ := ⟨cau_seq.completion.mk x⟩

theorem mk_eq {f g : cau_seq ℚ abs} : mk f = mk g ↔ f ≈ g :=
ext_cauchy_iff.trans mk_eq

@[irreducible]
private def lt : ℝ → ℝ → Prop | ⟨x⟩ ⟨y⟩ :=
quotient.lift_on₂ x y (<) $
  λ f₁ g₁ f₂ g₂ hf hg, propext $
  ⟨λ h, lt_of_eq_of_lt (setoid.symm hf) (lt_of_lt_of_eq h hg),
   λ h, lt_of_eq_of_lt hf (lt_of_lt_of_eq h (setoid.symm hg))⟩

instance : has_lt ℝ := ⟨lt⟩

lemma lt_cauchy {f g} : (⟨⟦f⟧⟩ : ℝ) < ⟨⟦g⟧⟩ ↔ f < g := show lt _ _ ↔ _, by rw lt; refl

@[simp] theorem mk_lt {f g : cau_seq ℚ abs} : mk f < mk g ↔ f < g :=
lt_cauchy

lemma mk_zero : mk 0 = 0 := by rw ← of_cauchy_zero; refl
lemma mk_one : mk 1 = 1 := by rw ← of_cauchy_one; refl
lemma mk_add {f g : cau_seq ℚ abs} : mk (f + g) = mk f + mk g := by simp [mk, ←of_cauchy_add]
lemma mk_mul {f g : cau_seq ℚ abs} : mk (f * g) = mk f * mk g := by simp [mk, ←of_cauchy_mul]
lemma mk_neg {f : cau_seq ℚ abs} : mk (-f) = -mk f := by simp [mk, ←of_cauchy_neg]

@[simp] theorem mk_pos {f : cau_seq ℚ abs} : 0 < mk f ↔ pos f :=
by rw [← mk_zero, mk_lt]; exact iff_of_eq (congr_arg pos (sub_zero f))

@[irreducible] private def le (x y : ℝ) : Prop := x < y ∨ x = y
instance : has_le ℝ := ⟨le⟩
private lemma le_def {x y : ℝ} : x ≤ y ↔ x < y ∨ x = y := show le _ _ ↔ _, by rw le

@[simp] theorem mk_le {f g : cau_seq ℚ abs} : mk f ≤ mk g ↔ f ≤ g :=
by simp [le_def, mk_eq]; refl

@[elab_as_eliminator]
protected lemma ind_mk {C : real → Prop} (x : real) (h : ∀ y, C (mk y)) : C x :=
begin
  cases x with x,
  induction x using quot.induction_on with x,
  exact h x
end

theorem add_lt_add_iff_left {a b : ℝ} (c : ℝ) : c + a < c + b ↔ a < b :=
begin
  induction a using real.ind_mk,
  induction b using real.ind_mk,
  induction c using real.ind_mk,
  simp only [mk_lt, ← mk_add],
  show pos _ ↔ pos _, rw add_sub_add_left_eq_sub
end

instance : partial_order ℝ :=
{ le := (≤), lt := (<),
  lt_iff_le_not_le := λ a b, real.ind_mk a $ λ a, real.ind_mk b $ λ b,
    by simpa using lt_iff_le_not_le,
  le_refl := λ a, a.ind_mk (by intro a; rw mk_le),
  le_trans := λ a b c, real.ind_mk a $ λ a, real.ind_mk b $ λ b, real.ind_mk c $ λ c,
    by simpa using le_trans,
  lt_iff_le_not_le := λ a b, real.ind_mk a $ λ a, real.ind_mk b $ λ b,
    by simpa using lt_iff_le_not_le,
  le_antisymm := λ a b, real.ind_mk a $ λ a, real.ind_mk b $ λ b,
    by simpa [mk_eq] using @cau_seq.le_antisymm _ _ a b }

instance : preorder ℝ := by apply_instance

theorem rat_cast_lt {x y : ℚ} : (x : ℝ) < (y : ℝ) ↔ x < y :=
begin
  rw [mk_lt] {md := tactic.transparency.semireducible},
  exact const_lt
end

protected theorem zero_lt_one : (0 : ℝ) < 1 :=
by convert rat_cast_lt.2 zero_lt_one; simp [←of_cauchy_rat_cast, of_cauchy_one, of_cauchy_zero]

protected lemma fact_zero_lt_one : fact ((0 : ℝ) < 1) := ⟨real.zero_lt_one⟩

protected theorem mul_pos {a b : ℝ} : 0 < a → 0 < b → 0 < a * b :=
begin
  induction a using real.ind_mk with a,
  induction b using real.ind_mk with b,
  simpa only [mk_lt, mk_pos, ← mk_mul] using cau_seq.mul_pos
end

instance : strict_ordered_comm_ring ℝ :=
{ exists_pair_ne := ⟨0, 1, real.zero_lt_one.ne⟩,
  add_le_add_left :=
  begin
    simp only [le_iff_eq_or_lt],
    rintros a b ⟨rfl, h⟩,
    { simp },
    { exact λ c, or.inr ((add_lt_add_iff_left c).2 ‹_›) }
  end,
  zero_le_one := le_of_lt real.zero_lt_one,
  mul_pos     := @real.mul_pos,
  .. real.comm_ring, .. real.partial_order, .. real.semiring }

instance : strict_ordered_ring ℝ            := infer_instance
instance : strict_ordered_comm_semiring ℝ   := infer_instance
instance : strict_ordered_semiring ℝ        := infer_instance
instance : ordered_ring ℝ                   := infer_instance
instance : ordered_semiring ℝ               := infer_instance
instance : ordered_add_comm_group ℝ         := infer_instance
instance : ordered_cancel_add_comm_monoid ℝ := infer_instance
instance : ordered_add_comm_monoid ℝ        := infer_instance
instance : nontrivial ℝ                     := infer_instance

@[irreducible]
private def sup : ℝ → ℝ → ℝ | ⟨x⟩ ⟨y⟩ :=
⟨quotient.map₂ (⊔) (λ x₁ x₂ hx y₁ y₂ hy, sup_equiv_sup hx hy) x y⟩

instance : has_sup ℝ := ⟨sup⟩

lemma of_cauchy_sup (a b) : (⟨⟦a ⊔ b⟧⟩ : ℝ) = ⟨⟦a⟧⟩ ⊔ ⟨⟦b⟧⟩ := show _ = sup _ _, by { rw sup, refl }
@[simp] lemma mk_sup (a b) : (mk (a ⊔ b) : ℝ) = mk a ⊔ mk b := of_cauchy_sup _ _

@[irreducible]
private def inf : ℝ → ℝ → ℝ | ⟨x⟩ ⟨y⟩ :=
⟨quotient.map₂ (⊓) (λ x₁ x₂ hx y₁ y₂ hy, inf_equiv_inf hx hy) x y⟩

instance : has_inf ℝ := ⟨inf⟩

lemma of_cauchy_inf (a b) : (⟨⟦a ⊓ b⟧⟩ : ℝ) = ⟨⟦a⟧⟩ ⊓ ⟨⟦b⟧⟩ := show _ = inf _ _, by { rw inf, refl }
@[simp] lemma mk_inf (a b) : (mk (a ⊓ b) : ℝ) = mk a ⊓ mk b := of_cauchy_inf _ _

instance : distrib_lattice ℝ :=
{ sup := (⊔),
  le := (≤),
  le_sup_left := λ a, real.ind_mk a $ λ a b, real.ind_mk b $ λ b, begin
    rw [←mk_sup, mk_le],
    exact cau_seq.le_sup_left,
  end,
  le_sup_right := λ a, real.ind_mk a $ λ a b, real.ind_mk b $ λ b, begin
    rw [←mk_sup, mk_le],
    exact cau_seq.le_sup_right,
  end,
  sup_le := λ a, real.ind_mk a $ λ a b, real.ind_mk b $ λ b c, real.ind_mk c $ λ c, begin
    simp_rw [←mk_sup, mk_le],
    exact cau_seq.sup_le,
  end,
  inf := (⊓),
  inf_le_left := λ a, real.ind_mk a $ λ a b, real.ind_mk b $ λ b, begin
    rw [←mk_inf, mk_le],
    exact cau_seq.inf_le_left,
  end,
  inf_le_right := λ a, real.ind_mk a $ λ a b, real.ind_mk b $ λ b, begin
    rw [←mk_inf, mk_le],
    exact cau_seq.inf_le_right,
  end,
  le_inf := λ a, real.ind_mk a $ λ a b, real.ind_mk b $ λ b c, real.ind_mk c $ λ c, begin
    simp_rw [←mk_inf, mk_le],
    exact cau_seq.le_inf,
  end,
  le_sup_inf := λ a, real.ind_mk a $ λ a b, real.ind_mk b $ λ b c, real.ind_mk c $ λ c, eq.le begin
    simp only [←mk_sup, ←mk_inf],
    exact congr_arg mk (cau_seq.sup_inf_distrib_left _ _ _).symm
  end,
  .. real.partial_order  }

/- Extra instances to short-circuit type class resolution -/
instance : lattice ℝ         := infer_instance
instance : semilattice_inf ℝ := infer_instance
instance : semilattice_sup ℝ := infer_instance

open_locale classical

instance : is_total ℝ (≤) :=
⟨λ a, real.ind_mk a $ λ a b, real.ind_mk b $ λ b, by simpa using le_total a b⟩

noncomputable instance : linear_order ℝ :=
lattice.to_linear_order _

noncomputable instance : linear_ordered_comm_ring ℝ :=
{ .. real.nontrivial, .. real.strict_ordered_ring, .. real.comm_ring, .. real.linear_order }

/- Extra instances to short-circuit type class resolution -/
noncomputable instance : linear_ordered_ring ℝ        := by apply_instance
noncomputable instance : linear_ordered_semiring ℝ    := by apply_instance
instance : is_domain ℝ :=
{ .. real.nontrivial, .. real.comm_ring, .. linear_ordered_ring.is_domain }

noncomputable instance : linear_ordered_field ℝ :=
{ inv := has_inv.inv,
  mul_inv_cancel := begin
    rintros ⟨a⟩ h,
    rw mul_comm,
    simp only [←of_cauchy_inv, ←of_cauchy_mul, ← of_cauchy_one, ← of_cauchy_zero, ne.def] at *,
    exact cau_seq.completion.inv_mul_cancel h,
  end,
  inv_zero := by simp [← of_cauchy_zero, ←of_cauchy_inv],
  rat_cast := coe,
  rat_cast_mk  := λ n d hd h2,
    by rw [←of_cauchy_rat_cast, rat.cast_mk', of_cauchy_mul, of_cauchy_inv, of_cauchy_nat_cast,
           of_cauchy_int_cast],
  ..real.linear_ordered_comm_ring }

/- Extra instances to short-circuit type class resolution -/

noncomputable instance : linear_ordered_add_comm_group ℝ          := by apply_instance
noncomputable instance field : field ℝ                            := by apply_instance
noncomputable instance : division_ring ℝ                          := by apply_instance
noncomputable instance decidable_lt (a b : ℝ) : decidable (a < b) := by apply_instance
noncomputable instance decidable_le (a b : ℝ) : decidable (a ≤ b) := by apply_instance
noncomputable instance decidable_eq (a b : ℝ) : decidable (a = b) := by apply_instance

/-- Show an underlying cauchy sequence for real numbers.

The representative chosen is the one passed in the VM to `quot.mk`, so two cauchy sequences
converging to the same number may be printed differently.
-/
meta instance : has_repr ℝ :=
{ repr := λ r, "real.of_cauchy " ++ repr r.cauchy }

theorem le_mk_of_forall_le {f : cau_seq ℚ abs} :
  (∃ i, ∀ j ≥ i, x ≤ f j) → x ≤ mk f :=
begin
  intro h,
  induction x using real.ind_mk with x,
  apply le_of_not_lt,
  rw mk_lt,
  rintro ⟨K, K0, hK⟩,
  obtain ⟨i, H⟩ := exists_forall_ge_and h
    (exists_forall_ge_and hK (f.cauchy₃ $ half_pos K0)),
  apply not_lt_of_le (H _ le_rfl).1,
  rw [mk_lt] {md := tactic.transparency.semireducible},
  refine ⟨_, half_pos K0, i, λ j ij, _⟩,
  have := add_le_add (H _ ij).2.1
    (le_of_lt (abs_lt.1 $ (H _ le_rfl).2.2 _ ij).1),
  rwa [← sub_eq_add_neg, sub_self_div_two, sub_apply, sub_add_sub_cancel] at this
end

theorem mk_near_of_forall_near {f : cau_seq ℚ abs} {x : ℝ} {ε : ℝ}
  (H : ∃ i, ∀ j ≥ i, |(f j : ℝ) - x| ≤ ε) : |mk f - x| ≤ ε :=
abs_sub_le_iff.2
  ⟨sub_le_iff_le_add'.2 $ mk_le_of_forall_le $
    H.imp $ λ i h j ij, sub_le_iff_le_add'.1 (abs_sub_le_iff.1 $ h j ij).1,
  sub_le_comm.1 $ le_mk_of_forall_le $
    H.imp $ λ i h j ij, sub_le_comm.1 (abs_sub_le_iff.1 $ h j ij).2⟩

instance : archimedean ℝ :=
archimedean_iff_rat_le.2 $ λ x, real.ind_mk x $ λ f,
let ⟨M, M0, H⟩ := f.bounded' 0 in
⟨M, mk_le_of_forall_le ⟨0, λ i _,
  rat.cast_le.2 $ le_of_lt (abs_lt.1 (H i)).2⟩⟩

noncomputable instance : floor_ring ℝ := archimedean.floor_ring _

theorem is_cau_seq_iff_lift {f : ℕ → ℚ} : is_cau_seq abs f ↔ is_cau_seq
  abs (λ i, (f i : ℝ)) :=
⟨λ H ε ε0,
  let ⟨δ, δ0, δε⟩ := exists_pos_rat_lt ε0 in
  (H _ δ0).imp $ λ i hi j ij, lt_trans
    (by simpa using (@rat.cast_lt ℝ _ _ _).2 (hi _ ij)) δε,
 λ H ε ε0, (H _ (rat.cast_pos.2 ε0)).imp $
   λ i hi j ij, (@rat.cast_lt ℝ _ _ _).1 $ by simpa using hi _ ij⟩

theorem of_near (f : ℕ → ℚ) (x : ℝ)
  (h : ∀ ε > 0, ∃ i, ∀ j ≥ i, |(f j : ℝ) - x| < ε) :
  ∃ h', real.mk ⟨f, h'⟩ = x :=
⟨is_cau_seq_iff_lift.2 (of_near _ (const abs x) h),
 sub_eq_zero.1 $ abs_eq_zero.1 $
  eq_of_le_of_forall_le_of_dense (abs_nonneg _) $ λ ε ε0,
    mk_near_of_forall_near $
    (h _ ε0).imp (λ i h j ij, le_of_lt (h j ij))⟩

theorem exists_floor (x : ℝ) : ∃ (ub : ℤ), (ub:ℝ) ≤ x ∧
   ∀ (z : ℤ), (z:ℝ) ≤ x → z ≤ ub :=
int.exists_greatest_of_bdd
  (let ⟨n, hn⟩ := exists_int_gt x in ⟨n, λ z h',
    int.cast_le.1 $ le_trans h' $ le_of_lt hn⟩)
  (let ⟨n, hn⟩ := exists_int_lt x in ⟨n, le_of_lt hn⟩)

theorem exists_is_lub (S : set ℝ) (hne : S.nonempty) (hbdd : bdd_above S) :
  ∃ x, is_lub S x :=
begin
  rcases ⟨hne, hbdd⟩ with ⟨⟨L, hL⟩, ⟨U, hU⟩⟩,
  have : ∀ d : ℕ, bdd_above {m : ℤ | ∃ y ∈ S, (m : ℝ) ≤ y * d},
  { cases exists_int_gt U with k hk,
    refine λ d, ⟨k * d, λ z h, _⟩,
    rcases h with ⟨y, yS, hy⟩,
    refine int.cast_le.1 (hy.trans _),
    push_cast,
    exact mul_le_mul_of_nonneg_right ((hU yS).trans hk.le) d.cast_nonneg },
  choose f hf using λ d : ℕ, int.exists_greatest_of_bdd (this d) ⟨⌊L * d⌋, L, hL, int.floor_le _⟩,
  have hf₁ : ∀ n > 0, ∃ y ∈ S, ((f n / n:ℚ):ℝ) ≤ y := λ n n0,
    let ⟨y, yS, hy⟩ := (hf n).1 in
    ⟨y, yS, by simpa using (div_le_iff ((nat.cast_pos.2 n0):((_:ℝ) < _))).2 hy⟩,
  have hf₂ : ∀ (n > 0) (y ∈ S), (y - (n:ℕ)⁻¹ : ℝ) < (f n / n:ℚ),
  { intros n n0 y yS,
    have := (int.sub_one_lt_floor _).trans_le (int.cast_le.2 $ (hf n).2 _ ⟨y, yS, int.floor_le _⟩),
    simp [-sub_eq_add_neg],
    rwa [lt_div_iff ((nat.cast_pos.2 n0):((_:ℝ) < _)), sub_mul, _root_.inv_mul_cancel],
    exact ne_of_gt (nat.cast_pos.2 n0) },
  have hg : is_cau_seq abs (λ n, f n / n : ℕ → ℚ),
  { intros ε ε0,
    suffices : ∀ j k ≥ ⌈ε⁻¹⌉₊, (f j / j - f k / k : ℚ) < ε,
    { refine ⟨_, λ j ij, abs_lt.2 ⟨_, this _ ij  _ le_rfl⟩⟩,
      rw [neg_lt, neg_sub], exact this _ le_rfl _ ij },
    intros j ij k ik,
    replace ij := le_trans (nat.le_ceil _) (nat.cast_le.2 ij),
    replace ik := le_trans (nat.le_ceil _) (nat.cast_le.2 ik),
    have j0 := nat.cast_pos.1 ((inv_pos.2 ε0).trans_le ij),
    have k0 := nat.cast_pos.1 ((inv_pos.2 ε0).trans_le ik),
    rcases hf₁ _ j0 with ⟨y, yS, hy⟩,
    refine lt_of_lt_of_le ((@rat.cast_lt ℝ _ _ _).1 _)
      ((inv_le ε0 (nat.cast_pos.2 k0)).1 ik),
    simpa using sub_lt_iff_lt_add'.2
      (lt_of_le_of_lt hy $ sub_lt_iff_lt_add.1 $ hf₂ _ k0 _ yS) },
  let g : cau_seq ℚ abs := ⟨λ n, f n / n, hg⟩,
  refine ⟨mk g, ⟨λ x xS, _, λ y h, _⟩⟩,
  { refine le_of_forall_ge_of_dense (λ z xz, _),
    cases exists_nat_gt (x - z)⁻¹ with K hK,
    refine le_mk_of_forall_le ⟨K, λ n nK, _⟩,
    replace xz := sub_pos.2 xz,
    replace hK := hK.le.trans (nat.cast_le.2 nK),
    have n0 : 0 < n := nat.cast_pos.1 ((inv_pos.2 xz).trans_le hK),
    refine le_trans _ (hf₂ _ n0 _ xS).le,
    rwa [le_sub_comm, inv_le ((nat.cast_pos.2 n0):((_:ℝ) < _)) xz] },
  { exact mk_le_of_forall_le ⟨1, λ n n1,
      let ⟨x, xS, hx⟩ := hf₁ _ n1 in le_trans hx (h xS)⟩ }
end

noncomputable instance : has_Sup ℝ :=
⟨λ S, if h : S.nonempty ∧ bdd_above S then classical.some (exists_is_lub S h.1 h.2) else 0⟩

lemma Sup_def (S : set ℝ) :
  Sup S = if h : S.nonempty ∧ bdd_above S
    then classical.some (exists_is_lub S h.1 h.2) else 0 := rfl

protected theorem is_lub_Sup (S : set ℝ) (h₁ : S.nonempty) (h₂ : bdd_above S) : is_lub S (Sup S) :=
by { simp only [Sup_def, dif_pos (and.intro h₁ h₂)], apply classical.some_spec }

noncomputable instance : has_Inf ℝ := ⟨λ S, -Sup (-S)⟩

lemma Inf_def (S : set ℝ) : Inf S = -Sup (-S) := rfl

protected theorem is_glb_Inf (S : set ℝ) (h₁ : S.nonempty) (h₂ : bdd_below S) :
  is_glb S (Inf S) :=
begin
  rw [Inf_def, ← is_lub_neg', neg_neg],
  exact real.is_lub_Sup _ h₁.neg h₂.neg
end

noncomputable instance : conditionally_complete_linear_order ℝ :=
{ Sup := has_Sup.Sup,
  Inf := has_Inf.Inf,
  le_cSup := λ s a hs ha, (real.is_lub_Sup s ⟨a, ha⟩ hs).1 ha,
  cSup_le := λ s a hs ha, (real.is_lub_Sup s hs ⟨a, ha⟩).2 ha,
  cInf_le := λ s a hs ha, (real.is_glb_Inf s ⟨a, ha⟩ hs).1 ha,
  le_cInf := λ s a hs ha, (real.is_glb_Inf s hs ⟨a, ha⟩).2 ha,
 ..real.linear_order, ..real.lattice}

lemma lt_Inf_add_pos {s : set ℝ} (h : s.nonempty) {ε : ℝ} (hε : 0 < ε) :
  ∃ a ∈ s, a < Inf s + ε :=
exists_lt_of_cInf_lt h $ lt_add_of_pos_right _ hε

lemma add_neg_lt_Sup {s : set ℝ} (h : s.nonempty) {ε : ℝ} (hε : ε < 0) :
  ∃ a ∈ s, Sup s + ε < a :=
exists_lt_of_lt_cSup h $ add_lt_iff_neg_left.2 hε

lemma Inf_le_iff {s : set ℝ} (h : bdd_below s) (h' : s.nonempty) {a : ℝ} :
  Inf s ≤ a ↔ ∀ ε, 0 < ε → ∃ x ∈ s, x < a + ε :=
begin
  rw le_iff_forall_pos_lt_add,
  split; intros H ε ε_pos,
  { exact exists_lt_of_cInf_lt h' (H ε ε_pos) },
  { rcases H ε ε_pos with ⟨x, x_in, hx⟩,
    exact cInf_lt_of_lt h x_in hx }
end

lemma le_Sup_iff {s : set ℝ} (h : bdd_above s) (h' : s.nonempty) {a : ℝ} :
  a ≤ Sup s ↔ ∀ ε, ε < 0 → ∃ x ∈ s, a + ε < x :=
begin
  rw le_iff_forall_pos_lt_add,
  refine ⟨λ H ε ε_neg, _, λ H ε ε_pos, _⟩,
  { exact exists_lt_of_lt_cSup h' (lt_sub_iff_add_lt.mp (H _ (neg_pos.mpr ε_neg))) },
  { rcases H _ (neg_lt_zero.mpr ε_pos) with ⟨x, x_in, hx⟩,
    exact sub_lt_iff_lt_add.mp (lt_cSup_of_lt h x_in hx) }
end

@[simp] theorem Sup_empty : Sup (∅ : set ℝ) = 0 := dif_neg $ by simp

lemma csupr_empty {α : Sort*} [is_empty α] (f : α → ℝ) : (⨆ i, f i) = 0 :=
begin
  dsimp [supr],
  convert real.Sup_empty,
  rw set.range_eq_empty_iff,
  apply_instance
end

@[simp] lemma csupr_const_zero {α : Sort*} : (⨆ i : α, (0:ℝ)) = 0 :=
begin
  casesI is_empty_or_nonempty α,
  { exact real.csupr_empty _ },
  { exact csupr_const },
end

theorem Sup_of_not_bdd_above {s : set ℝ} (hs : ¬ bdd_above s) : Sup s = 0 :=
dif_neg $ assume h, hs h.2

lemma supr_of_not_bdd_above {α : Sort*} {f : α → ℝ} (hf : ¬ bdd_above (set.range f)) :
  (⨆ i, f i) = 0 := Sup_of_not_bdd_above hf

theorem Sup_univ : Sup (@set.univ ℝ) = 0 :=
real.Sup_of_not_bdd_above $ λ ⟨x, h⟩, not_le_of_lt (lt_add_one _) $ h (set.mem_univ _)

@[simp] theorem Inf_empty : Inf (∅ : set ℝ) = 0 :=
by simp [Inf_def, Sup_empty]

lemma cinfi_empty {α : Sort*} [is_empty α] (f : α → ℝ) : (⨅ i, f i) = 0 :=
by rw [infi_of_empty', Inf_empty]

@[simp] lemma cinfi_const_zero {α : Sort*} : (⨅ i : α, (0:ℝ)) = 0 :=
begin
  casesI is_empty_or_nonempty α,
  { exact real.cinfi_empty _ },
  { exact cinfi_const },
end

theorem Inf_of_not_bdd_below {s : set ℝ} (hs : ¬ bdd_below s) : Inf s = 0 :=
neg_eq_zero.2 $ Sup_of_not_bdd_above $ mt bdd_above_neg.1 hs

lemma infi_of_not_bdd_below  {α : Sort*} {f : α → ℝ} (hf : ¬ bdd_below (set.range f)) :
  (⨅ i, f i) = 0 := Inf_of_not_bdd_below hf

/--
As `0` is the default value for `real.Sup` of the empty set or sets which are not bounded above, it
suffices to show that `S` is bounded below by `0` to show that `0 ≤ Inf S`.
-/
lemma Sup_nonneg (S : set ℝ) (hS : ∀ x ∈ S, (0:ℝ) ≤ x) : 0 ≤ Sup S :=
begin
  rcases S.eq_empty_or_nonempty with rfl | ⟨y, hy⟩,
  { exact Sup_empty.ge },
  { apply dite _ (λ h, le_cSup_of_le h hy $ hS y hy) (λ h, (Sup_of_not_bdd_above h).ge) }
end

/--
As `0` is the default value for `real.Sup` of the empty set, it suffices to show that `S` is
bounded above by `0` to show that `Sup S ≤ 0`.
-/
lemma Sup_nonpos (S : set ℝ) (hS : ∀ x ∈ S, x ≤ (0:ℝ)) : Sup S ≤ 0 :=
begin
  rcases S.eq_empty_or_nonempty with rfl | hS₂,
  exacts [Sup_empty.le, cSup_le hS₂ hS],
end

/--
As `0` is the default value for `real.Inf` of the empty set, it suffices to show that `S` is
bounded below by `0` to show that `0 ≤ Inf S`.
-/
lemma Inf_nonneg (S : set ℝ) (hS : ∀ x ∈ S, (0:ℝ) ≤ x) : 0 ≤ Inf S :=
begin
  rcases S.eq_empty_or_nonempty with rfl | hS₂,
  exacts [Inf_empty.ge, le_cInf hS₂ hS]
end

/--
As `0` is the default value for `real.Inf` of the empty set or sets which are not bounded below, it
suffices to show that `S` is bounded above by `0` to show that `Inf S ≤ 0`.
-/
lemma Inf_nonpos (S : set ℝ) (hS : ∀ x ∈ S, x ≤ (0:ℝ)) : Inf S ≤ 0 :=
begin
  rcases S.eq_empty_or_nonempty with rfl | ⟨y, hy⟩,
  { exact Inf_empty.le },
  { apply dite _ (λ h, cInf_le_of_le h hy $ hS y hy) (λ h, (Inf_of_not_bdd_below h).le) }
end

lemma Inf_le_Sup (s : set ℝ) (h₁ : bdd_below s) (h₂ : bdd_above s) : Inf s ≤ Sup s :=
begin
  rcases s.eq_empty_or_nonempty with rfl | hne,
  { rw [Inf_empty, Sup_empty] },
  { exact cInf_le_cSup h₁ h₂ hne }
end

theorem cau_seq_converges (f : cau_seq ℝ abs) : ∃ x, f ≈ const abs x :=
begin
  let S := {x : ℝ | const abs x < f},
  have lb : ∃ x, x ∈ S := exists_lt f,
  have ub' : ∀ x, f < const abs x → ∀ y ∈ S, y ≤ x :=
    λ x h y yS, le_of_lt $ const_lt.1 $ cau_seq.lt_trans yS h,
  have ub : ∃ x, ∀ y ∈ S, y ≤ x := (exists_gt f).imp ub',
  refine ⟨Sup S,
    ((lt_total _ _).resolve_left (λ h, _)).resolve_right (λ h, _)⟩,
  { rcases h with ⟨ε, ε0, i, ih⟩,
    refine (cSup_le lb (ub' _ _)).not_lt (sub_lt_self _ (half_pos ε0)),
    refine ⟨_, half_pos ε0, i, λ j ij, _⟩,
    rw [sub_apply, const_apply, sub_right_comm,
      le_sub_iff_add_le, add_halves],
    exact ih _ ij },
  { rcases h with ⟨ε, ε0, i, ih⟩,
    refine (le_cSup ub _).not_lt ((lt_add_iff_pos_left _).2 (half_pos ε0)),
    refine ⟨_, half_pos ε0, i, λ j ij, _⟩,
    rw [sub_apply, const_apply, add_comm, ← sub_sub,
      le_sub_iff_add_le, add_halves],
    exact ih _ ij }
end

instance : cau_seq.is_complete ℝ abs := ⟨cau_seq_converges⟩

end real


-- Pruebas de (Q → R) → ((¬Q → ¬P) → (P → R))
-- ==========================================

-- ----------------------------------------------------
-- Ej. 1. (p. 10) Demostrar
--    (Q → R) → ((¬Q → ¬P) → (P → R))
-- ----------------------------------------------------

import tactic

variables (P Q R : Prop)

-- 1ª demostración
example :
  (Q → R) → ((¬Q → ¬P) → (P → R)) :=
assume h1 : Q → R,
show (¬Q → ¬P) → (P → R), from
  ( assume h2 : ¬Q → ¬P,
    show P → R, from
      ( assume h3 : P,
        have h4 : ¬¬P, from not_not_intro h3,
        have h5 : ¬¬Q, from mt h2 h4,
        have h6 : Q,   from not_not.mp h5,
        show R, from h1 h6))

-- 2ª demostración
example :
  (Q → R) → ((¬Q → ¬P) → (P → R)) :=
assume h1 : Q → R,
show (¬Q → ¬P) → (P → R), from
  ( assume h2 : ¬Q → ¬P,
    show P → R, from
      ( assume h3 : P,
        have h4 : ¬¬P, from not_not_intro h3,
        have h5 : ¬¬Q, from mt h2 h4,
        have h6 : Q,   from not_not.mp h5,
        h1 h6))

-- 3ª demostración
example :
  (Q → R) → ((¬Q → ¬P) → (P → R)) :=
assume h1 : Q → R,
show (¬Q → ¬P) → (P → R), from
  ( assume h2 : ¬Q → ¬P,
    show P → R, from
      ( assume h3 : P,
        have h4 : ¬¬P, from not_not_intro h3,
        have h5 : ¬¬Q, from mt h2 h4,
        h1 (not_not.mp h5)))

-- 4ª demostración
example :
  (Q → R) → ((¬Q → ¬P) → (P → R)) :=
assume h1 : Q → R,
show (¬Q → ¬P) → (P → R), from
  ( assume h2 : ¬Q → ¬P,
    show P → R, from
      ( assume h3 : P,
        have h4 : ¬¬P, from not_not_intro h3,
        h1 (not_not.mp (mt h2 h4))))

-- 5ª demostración
example :
  (Q → R) → ((¬Q → ¬P) → (P → R)) :=
assume h1 : Q → R,
show (¬Q → ¬P) → (P → R), from
  ( assume h2 : ¬Q → ¬P,
    show P → R, from
      ( assume h3 : P,
        h1 (not_not.mp (mt h2 (not_not_intro h3)))))

-- 6ª demostración
example :
  (Q → R) → ((¬Q → ¬P) → (P → R)) :=
assume h1 : Q → R,
show (¬Q → ¬P) → (P → R), from
  ( assume h2 : ¬Q → ¬P,
    show P → R, from
      (λh3, h1 (not_not.mp (mt h2 (not_not_intro h3)))))

-- 7ª demostración
example :
  (Q → R) → ((¬Q → ¬P) → (P → R)) :=
assume h1 : Q → R,
show (¬Q → ¬P) → (P → R), from
  ( assume h2 : ¬Q → ¬P,
    (λh3, h1 (not_not.mp (mt h2 (not_not_intro h3)))))

-- 8ª demostración
example :
  (Q → R) → ((¬Q → ¬P) → (P → R)) :=
assume h1 : Q → R,
show (¬Q → ¬P) → (P → R), from
  ( λh2,
    (λh3, h1 (not_not.mp (mt h2 (not_not_intro h3)))))

-- 9ª demostración
example :
  (Q → R) → ((¬Q → ¬P) → (P → R)) :=
assume h1 : Q → R,
(λ h2 h3, h1 (not_not.mp (mt h2 (not_not_intro h3))))

-- 10ª demostración
example :
  (Q → R) → ((¬Q → ¬P) → (P → R)) :=
λ h1 h2 h3, h1 (not_not.mp (mt h2 (not_not_intro h3)))

-- 11ª demostración
example :
  (Q → R) → ((¬Q → ¬P) → (P → R)) :=
begin
  intro h1,
  intro h2,
  intro h3,
  apply h1,
  apply not_not.mp,
  apply mt h2,
  exact not_not_intro h3,
end

-- 12ª demostración
example :
  (Q → R) → ((¬Q → ¬P) → (P → R)) :=
begin
  intros h1 h2 h3,
  apply h1,
  apply not_not.mp,
  apply mt h2,
  exact not_not_intro h3,
end

-- 13ª demostración
example :
  (Q → R) → ((¬Q → ¬P) → (P → R)) :=
begin
  intros h1 h2 h3,
  apply h1,
  apply not_not.mp,
  exact mt h2 (not_not_intro h3),
end

-- 14ª demostración
example :
  (Q → R) → ((¬Q → ¬P) → (P → R)) :=
begin
  intros h1 h2 h3,
  exact h1 (not_not.mp (mt h2 (not_not_intro h3))),
end

-- 15ª demostración
example :
  (Q → R) → ((¬Q → ¬P) → (P → R)) :=
λ h1 h2 h3, h1 (not_not.mp (mt h2 (not_not_intro h3)))

-- 16ª demostración
lemma aux :
  (Q → R) → ((¬Q → ¬P) → (P → R)) :=
-- by hint
by finish

-- #print axioms aux


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.category.Mon.basic
import Mathlib.category_theory.limits.limits
import Mathlib.category_theory.limits.concrete_category
import Mathlib.PostPort

universes v l u_1

namespace Mathlib

/-!
# The category of monoids has all colimits.

We do this construction knowing nothing about monoids.
In particular, I want to claim that this file could be produced by a python script
that just looks at the output of `#print monoid`:

  -- structure monoid : Type u → Type u
  -- fields:
  -- monoid.mul : Π {α : Type u} [c : monoid α], α → α → α
  -- monoid.mul_assoc : ∀ {α : Type u} [c : monoid α] (a b c_1 : α), a * b * c_1 = a * (b * c_1)
  -- monoid.one : Π (α : Type u) [c : monoid α], α
  -- monoid.one_mul : ∀ {α : Type u} [c : monoid α] (a : α), 1 * a = a
  -- monoid.mul_one : ∀ {α : Type u} [c : monoid α] (a : α), a * 1 = a

and if we'd fed it the output of `#print comm_ring`, this file would instead build
colimits of commutative rings.

A slightly bolder claim is that we could do this with tactics, as well.
-/

namespace Mon.colimits

/-!
We build the colimit of a diagram in `Mon` by constructing the
free monoid on the disjoint union of all the monoids in the diagram,
then taking the quotient by the monoid laws within each monoid,
and the identifications given by the morphisms in the diagram.
-/

/--
An inductive type representing all monoid expressions (without relations)
on a collection of types indexed by the objects of `J`.
-/
-- There's always `of`

inductive prequotient {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon)
where
| of : (j : J) → ↥(category_theory.functor.obj F j) → prequotient F
| one : prequotient F
| mul : prequotient F → prequotient F → prequotient F

-- Then one generator for each operation

protected instance prequotient.inhabited {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) : Inhabited (prequotient F) :=
  { default := prequotient.one }

/--
The relation on `prequotient` saying when two expressions are equal
because of the monoid laws, or
because one element is mapped to another by a morphism in the diagram.
-/
-- Make it an equivalence relation:

inductive relation {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) : prequotient F → prequotient F → Prop
where
| refl : ∀ (x : prequotient F), relation F x x
| symm : ∀ (x y : prequotient F), relation F x y → relation F y x
| trans : ∀ (x y z : prequotient F), relation F x y → relation F y z → relation F x z
| map : ∀ (j j' : J) (f : j ⟶ j') (x : ↥(category_theory.functor.obj F j)),
  relation F (prequotient.of j' (coe_fn (category_theory.functor.map F f) x)) (prequotient.of j x)
| mul : ∀ (j : J) (x y : ↥(category_theory.functor.obj F j)),
  relation F (prequotient.of j (x * y)) (prequotient.mul (prequotient.of j x) (prequotient.of j y))
| one : ∀ (j : J), relation F (prequotient.of j 1) prequotient.one
| mul_1 : ∀ (x x' y : prequotient F), relation F x x' → relation F (prequotient.mul x y) (prequotient.mul x' y)
| mul_2 : ∀ (x y y' : prequotient F), relation F y y' → relation F (prequotient.mul x y) (prequotient.mul x y')
| mul_assoc : ∀ (x y z : prequotient F),
  relation F (prequotient.mul (prequotient.mul x y) z) (prequotient.mul x (prequotient.mul y z))
| one_mul : ∀ (x : prequotient F), relation F (prequotient.mul prequotient.one x) x
| mul_one : ∀ (x : prequotient F), relation F (prequotient.mul x prequotient.one) x

-- There's always a `map` relation

-- Then one relation per operation, describing the interaction with `of`

-- Then one relation per argument of each operation

-- And one relation per axiom

/--
The setoid corresponding to monoid expressions modulo monoid relations and identifications.
-/
instance colimit_setoid {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) : setoid (prequotient F) :=
  setoid.mk (relation F) sorry

/--
The underlying type of the colimit of a diagram in `Mon`.
-/
def colimit_type {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) :=
  quotient (colimit_setoid F)

protected instance monoid_colimit_type {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) : monoid (colimit_type F) :=
  monoid.mk
    (Quot.lift
      (fun (x : prequotient F) => Quot.lift (fun (y : prequotient F) => Quot.mk setoid.r (prequotient.mul x y)) sorry)
      sorry)
    sorry (Quot.mk setoid.r prequotient.one) sorry sorry

@[simp] theorem quot_one {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) : Quot.mk setoid.r prequotient.one = 1 :=
  rfl

@[simp] theorem quot_mul {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) (x : prequotient F) (y : prequotient F) : Quot.mk setoid.r (prequotient.mul x y) = Quot.mk setoid.r x * Quot.mk setoid.r y :=
  rfl

/-- The bundled monoid giving the colimit of a diagram. -/
def colimit {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) : Mon :=
  category_theory.bundled.mk (colimit_type F)

/-- The function from a given monoid in the diagram to the colimit monoid. -/
def cocone_fun {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) (j : J) (x : ↥(category_theory.functor.obj F j)) : colimit_type F :=
  Quot.mk setoid.r (prequotient.of j x)

/-- The monoid homomorphism from a given monoid in the diagram to the colimit monoid. -/
def cocone_morphism {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) (j : J) : category_theory.functor.obj F j ⟶ colimit F :=
  monoid_hom.mk (cocone_fun F j) sorry sorry

@[simp] theorem cocone_naturality {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) {j : J} {j' : J} (f : j ⟶ j') : category_theory.functor.map F f ≫ cocone_morphism F j' = cocone_morphism F j :=
  monoid_hom.ext fun (x : ↥(category_theory.functor.obj F j)) => quot.sound (relation.map j j' f x)

@[simp] theorem cocone_naturality_components {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) (j : J) (j' : J) (f : j ⟶ j') (x : ↥(category_theory.functor.obj F j)) : coe_fn (cocone_morphism F j') (coe_fn (category_theory.functor.map F f) x) = coe_fn (cocone_morphism F j) x := sorry

/-- The cocone over the proposed colimit monoid. -/
def colimit_cocone {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) : category_theory.limits.cocone F :=
  category_theory.limits.cocone.mk (colimit F) (category_theory.nat_trans.mk (cocone_morphism F))

/-- The function from the free monoid on the diagram to the cone point of any other cocone. -/
@[simp] def desc_fun_lift {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) (s : category_theory.limits.cocone F) : prequotient F → ↥(category_theory.limits.cocone.X s) :=
  sorry

/-- The function from the colimit monoid to the cone point of any other cocone. -/
def desc_fun {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) (s : category_theory.limits.cocone F) : colimit_type F → ↥(category_theory.limits.cocone.X s) :=
  Quot.lift (desc_fun_lift F s) sorry

/-- The monoid homomorphism from the colimit monoid to the cone point of any other cocone. -/
def desc_morphism {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) (s : category_theory.limits.cocone F) : colimit F ⟶ category_theory.limits.cocone.X s :=
  monoid_hom.mk (desc_fun F s) sorry sorry

/-- Evidence that the proposed colimit is the colimit. -/
def colimit_is_colimit {J : Type v} [category_theory.small_category J] (F : J ⥤ Mon) : category_theory.limits.is_colimit (colimit_cocone F) :=
  category_theory.limits.is_colimit.mk fun (s : category_theory.limits.cocone F) => desc_morphism F s

protected instance has_colimits_Mon : category_theory.limits.has_colimits Mon :=
  category_theory.limits.has_colimits.mk
    fun (J : Type u_1) (𝒥 : category_theory.small_category J) =>
      category_theory.limits.has_colimits_of_shape.mk
        fun (F : J ⥤ Mon) =>
          category_theory.limits.has_colimit.mk
            (category_theory.limits.colimit_cocone.mk (colimit_cocone F) (colimit_is_colimit F))


/-
Copyright (c) 2019 Lucas Allen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Lucas Allen, Scott Morrison
-/

import algebra.big_operators.finsupp
import tactic.converter.apply_congr
import tactic.interactive

example (f g : ℤ → ℤ) (S : finset ℤ) (h : ∀ m ∈ S, f m = g m) :
  finset.sum S f = finset.sum S g :=
begin
  conv_lhs {
    -- If we just call `congr` here, in the second goal we're helpless,
    -- because we are only given the opportunity to rewrite `f`.

    -- However `apply_congr` uses the appropriate `@[congr]` lemma,
    -- so we get to rewrite `f x`, in the presence of the crucial `H : x ∈ S` hypothesis.
    apply_congr,
    skip,
    simp [h, H], }
end

-- Again, with some `guard` statements.
example (f g : ℤ → ℤ) (S : finset ℤ) (h : ∀ m ∈ S, f m = g m) :
  finset.sum S f = finset.sum S g :=
begin
  conv_lhs {
    apply_congr finset.sum_congr,
    -- (See the note about get_goals/set_goals inside apply_congr)
    (do ng ← tactic.num_goals, guard $ ng = 2),
    guard_target S,
    skip,
    guard_target f x,
    simp [h, H] }
end

-- Verify we can `rw` as well as `simp`.
example (f g : ℤ → ℤ) (S : finset ℤ) (h : ∀ m ∈ S, f m = g m) :
  finset.sum S f = finset.sum S g :=
by conv_lhs { apply_congr, skip, rw h x H, }

-- Check that the appropriate `@[congr]` lemma is automatically selected.
example (f g : ℤ → ℤ) (S : finset ℤ) (h : ∀ m ∈ S, f m = g m) :
  finset.prod S f = finset.prod S g :=
by conv_lhs { apply_congr, skip, simp [h, H], }

example (f g : ℤ → ℤ) (S : finset ℤ) (h : ∀ m ∈ S, f m = g m) :
  finset.fold (+) 0 f S = finset.fold (+) 0 g S :=
begin
  -- This time, the automatically selected congruence lemma is "too good"!
  -- `finset.sum_congr` matches, and so the `conv` block actually
  -- rewrites the left hand side into a `finset.sum`.
  conv_lhs { apply_congr, skip, simp [h, H], },
  -- So we need a `refl` to identify that we're done.
  refl,
end

-- This can be avoided by selecting the congruence lemma by hand.
example (f g : ℤ → ℤ) (S : finset ℤ) (h : ∀ m ∈ S, f m = g m) :
  finset.fold (+) 0 f S = finset.fold (+) 0 g S :=
begin
  conv_lhs { apply_congr finset.fold_congr, simp [h, H], },
end

example (f : ℤ → ℤ) (S : finset ℤ) (h : ∀ m ∈ S, f m = 0) :
  finset.sum S f = 0 :=
begin
  conv_lhs { apply_congr, skip, simp [h, H], },
  simp,
end

-- An example using `finsupp.sum`
open_locale classical

example {k G : Type} [semiring k] [group G]
  (g : G →₀ k) (a₁ x : G) (b₁ : k)
  (t : ∀ (a₂ : G), a₁ * a₂ = x ↔ a₁⁻¹ * x = a₂) :
  g.sum (λ (a₂ : G) (b₂ : k), ite (a₁ * a₂ = x) (b₁ * b₂) 0) = b₁ * g (a₁⁻¹ * x) :=
begin
  -- In fact, `congr` works fine here, because our rewrite works globally.
  conv_lhs { apply_congr, skip, dsimp, rw t, },
  rw finset.sum_ite_eq g.support, -- it's a pity we can't just use `simp` here.
  split_ifs,
  { refl, },
  { simp [finsupp.not_mem_support_iff.1 h], },
end

example : true :=
begin
  success_if_fail { conv { apply_congr, }, },
  trivial
end


/-
Copyright (c) 2020 Yury Kudryashov All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov, Heather Macbeth

! This file was ported from Lean 3 source module analysis.normed_space.hahn_banach.extension
! leanprover-community/mathlib commit 17ef379e997badd73e5eabb4d38f11919ab3c4b3
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Analysis.Convex.Cone.Basic
import Mathbin.Analysis.NormedSpace.IsROrC
import Mathbin.Analysis.NormedSpace.Extend

/-!
# Extension Hahn-Banach theorem

In this file we prove the analytic Hahn-Banach theorem. For any continuous linear function on a
subspace, we can extend it to a function on the entire space without changing its norm.

We prove
* `real.exists_extension_norm_eq`: Hahn-Banach theorem for continuous linear functions on normed
  spaces over `ℝ`.
* `exists_extension_norm_eq`: Hahn-Banach theorem for continuous linear functions on normed spaces
  over `ℝ` or `ℂ`.

In order to state and prove the corollaries uniformly, we prove the statements for a field `𝕜`
satisfying `is_R_or_C 𝕜`.

In this setting, `exists_dual_vector` states that, for any nonzero `x`, there exists a continuous
linear form `g` of norm `1` with `g x = ‖x‖` (where the norm has to be interpreted as an element
of `𝕜`).

-/

universe u v

namespace Real

variable {E : Type _} [SeminormedAddCommGroup E] [NormedSpace ℝ E]

/-- Hahn-Banach theorem for continuous linear functions over `ℝ`. -/
theorem exists_extension_norm_eq (p : Subspace ℝ E) (f : p →L[ℝ] ℝ) :
    ∃ g : E →L[ℝ] ℝ, (∀ x : p, g x = f x) ∧ ‖g‖ = ‖f‖ :=
  by
  rcases exists_extension_of_le_sublinear ⟨p, f⟩ (fun x => ‖f‖ * ‖x‖)
      (fun c hc x => by simp only [norm_smul c x, Real.norm_eq_abs, abs_of_pos hc, mul_left_comm])
      (fun x y => _) fun x => le_trans (le_abs_self _) (f.le_op_norm _) with
    ⟨g, g_eq, g_le⟩
  set g' :=
    g.mk_continuous ‖f‖ fun x => abs_le.2 ⟨neg_le.1 <| g.map_neg x ▸ norm_neg x ▸ g_le (-x), g_le x⟩
  · refine' ⟨g', g_eq, _⟩
    · apply le_antisymm (g.mk_continuous_norm_le (norm_nonneg f) _)
      refine' f.op_norm_le_bound (norm_nonneg _) fun x => _
      dsimp at g_eq
      rw [← g_eq]
      apply g'.le_op_norm
  · simp only [← mul_add]
    exact mul_le_mul_of_nonneg_left (norm_add_le x y) (norm_nonneg f)
#align real.exists_extension_norm_eq Real.exists_extension_norm_eq

end Real

section IsROrC

open IsROrC

variable {𝕜 : Type _} [IsROrC 𝕜] {F : Type _} [SeminormedAddCommGroup F] [NormedSpace 𝕜 F]

/-- Hahn-Banach theorem for continuous linear functions over `𝕜` satisyfing `is_R_or_C 𝕜`. -/
theorem exists_extension_norm_eq (p : Subspace 𝕜 F) (f : p →L[𝕜] 𝕜) :
    ∃ g : F →L[𝕜] 𝕜, (∀ x : p, g x = f x) ∧ ‖g‖ = ‖f‖ :=
  by
  letI : Module ℝ F := RestrictScalars.module ℝ 𝕜 F
  letI : IsScalarTower ℝ 𝕜 F := RestrictScalars.isScalarTower _ _ _
  letI : NormedSpace ℝ F := NormedSpace.restrictScalars _ 𝕜 _
  -- Let `fr: p →L[ℝ] ℝ` be the real part of `f`.
  let fr := re_clm.comp (f.restrict_scalars ℝ)
  have fr_apply : ∀ x, fr x = re (f x) := by
    intro x
    rfl
  -- Use the real version to get a norm-preserving extension of `fr`, which
  -- we'll call `g : F →L[ℝ] ℝ`.
  rcases Real.exists_extension_norm_eq (p.restrict_scalars ℝ) fr with ⟨g, ⟨hextends, hnormeq⟩⟩
  -- Now `g` can be extended to the `F →L[𝕜] 𝕜` we need.
  refine' ⟨g.extend_to_𝕜, _⟩
  -- It is an extension of `f`.
  have h : ∀ x : p, g.extend_to_𝕜 x = f x := by
    intro x
    rw [ContinuousLinearMap.extendTo𝕜_apply, ← Submodule.coe_smul, hextends, hextends]
    have : (fr x : 𝕜) - I * ↑(fr (I • x)) = (re (f x) : 𝕜) - (I : 𝕜) * re (f ((I : 𝕜) • x)) := by
      rfl
    rw [this]
    apply ext
    ·
      simp only [add_zero, Algebra.id.smul_eq_mul, I_re, of_real_im, AddMonoidHom.map_add, zero_sub,
        I_im', MulZeroClass.zero_mul, of_real_re, eq_self_iff_true, sub_zero, mul_neg, of_real_neg,
        mul_re, MulZeroClass.mul_zero, sub_neg_eq_add, ContinuousLinearMap.map_smul]
    ·
      simp only [Algebra.id.smul_eq_mul, I_re, of_real_im, AddMonoidHom.map_add, zero_sub, I_im',
        MulZeroClass.zero_mul, of_real_re, mul_neg, mul_im, zero_add, of_real_neg, mul_re,
        sub_neg_eq_add, ContinuousLinearMap.map_smul]
  -- And we derive the equality of the norms by bounding on both sides.
  refine' ⟨h, le_antisymm _ _⟩
  ·
    calc
      ‖g.extend_to_𝕜‖ ≤ ‖g‖ := g.extend_to_𝕜.op_norm_le_bound g.op_norm_nonneg (norm_bound _)
      _ = ‖fr‖ := hnormeq
      _ ≤ ‖re_clm‖ * ‖f‖ := (ContinuousLinearMap.op_norm_comp_le _ _)
      _ = ‖f‖ := by rw [re_clm_norm, one_mul]

  · exact f.op_norm_le_bound g.extend_to_𝕜.op_norm_nonneg fun x => h x ▸ g.extend_to_𝕜.le_op_norm x
#align exists_extension_norm_eq exists_extension_norm_eq

end IsROrC

section DualVector

variable (𝕜 : Type v) [IsROrC 𝕜]

variable {E : Type u} [NormedAddCommGroup E] [NormedSpace 𝕜 E]

open ContinuousLinearEquiv Submodule

open Classical

theorem coord_norm' {x : E} (h : x ≠ 0) : ‖(‖x‖ : 𝕜) • coord 𝕜 x h‖ = 1 := by
  rw [norm_smul, IsROrC.norm_coe_norm, coord_norm, mul_inv_cancel (mt norm_eq_zero.mp h)]
#align coord_norm' coord_norm'

/-- Corollary of Hahn-Banach.  Given a nonzero element `x` of a normed space, there exists an
    element of the dual space, of norm `1`, whose value on `x` is `‖x‖`. -/
theorem exists_dual_vector (x : E) (h : x ≠ 0) : ∃ g : E →L[𝕜] 𝕜, ‖g‖ = 1 ∧ g x = ‖x‖ :=
  by
  let p : Submodule 𝕜 E := 𝕜 ∙ x
  let f := (‖x‖ : 𝕜) • coord 𝕜 x h
  obtain ⟨g, hg⟩ := exists_extension_norm_eq p f
  refine' ⟨g, _, _⟩
  · rw [hg.2, coord_norm']
  ·
    calc
      g x = g (⟨x, mem_span_singleton_self x⟩ : 𝕜 ∙ x) := by rw [coe_mk]
      _ = ((‖x‖ : 𝕜) • coord 𝕜 x h) (⟨x, mem_span_singleton_self x⟩ : 𝕜 ∙ x) := by rw [← hg.1]
      _ = ‖x‖ := by simp

#align exists_dual_vector exists_dual_vector

/-- Variant of Hahn-Banach, eliminating the hypothesis that `x` be nonzero, and choosing
    the dual element arbitrarily when `x = 0`. -/
theorem exists_dual_vector' [Nontrivial E] (x : E) : ∃ g : E →L[𝕜] 𝕜, ‖g‖ = 1 ∧ g x = ‖x‖ :=
  by
  by_cases hx : x = 0
  · obtain ⟨y, hy⟩ := exists_ne (0 : E)
    obtain ⟨g, hg⟩ : ∃ g : E →L[𝕜] 𝕜, ‖g‖ = 1 ∧ g y = ‖y‖ := exists_dual_vector 𝕜 y hy
    refine' ⟨g, hg.left, _⟩
    simp [hx]
  · exact exists_dual_vector 𝕜 x hx
#align exists_dual_vector' exists_dual_vector'

/-- Variant of Hahn-Banach, eliminating the hypothesis that `x` be nonzero, but only ensuring that
    the dual element has norm at most `1` (this can not be improved for the trivial
    vector space). -/
theorem exists_dual_vector'' (x : E) : ∃ g : E →L[𝕜] 𝕜, ‖g‖ ≤ 1 ∧ g x = ‖x‖ :=
  by
  by_cases hx : x = 0
  · refine' ⟨0, by simp, _⟩
    symm
    simp [hx]
  · rcases exists_dual_vector 𝕜 x hx with ⟨g, g_norm, g_eq⟩
    exact ⟨g, g_norm.le, g_eq⟩
#align exists_dual_vector'' exists_dual_vector''

end DualVector


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/

import algebra.big_operators.basic
import data.finset.option

/-!
# Lemmas about products and sums over finite sets in `option α`

In this file we prove formulas for products and sums over `finset.insert_none s` and
`finset.erase_none s`.
-/

open_locale big_operators
open function

namespace finset

variables {α M : Type*} [comm_monoid M]

@[simp, to_additive] lemma prod_insert_none (f : option α → M) (s : finset α) :
  ∏ x in s.insert_none, f x = f none * ∏ x in s, f (some x) :=
by simp [insert_none]

@[to_additive] lemma prod_erase_none (f : α → M) (s : finset (option α)) :
  ∏ x in s.erase_none, f x = ∏ x in s, option.elim 1 f x :=
by classical;
calc ∏ x in s.erase_none, f x = ∏ x in s.erase_none.map embedding.some, option.elim 1 f x :
  (prod_map s.erase_none embedding.some $ option.elim 1 f).symm
... = ∏ x in s.erase none, option.elim 1 f x : by rw map_some_erase_none
... = ∏ x in s, option.elim 1 f x : prod_erase _ rfl

end finset


import data.real.basic
import tactic.apply_fun

namespace tactic.interactive
setup_tactic_parser

meta def compute_at_hyp (h : name) : tactic unit :=
let lo := loc.ns [h] in
do { ring none tactic.ring.normalize_mode.horner lo <|>
norm_num [] lo <|>
abel tactic.abel.normalize_mode.term lo } ; try (simp_core {} skip ff [] [] lo)

meta def compute_at_goal : tactic unit :=
do focus (tactic.iterate_at_most 3 `[refl <|> ring <|> abel <|> norm_num])

meta def compute_at (h : option name) :=
if H : h.is_some then compute_at_hyp (option.get H) else compute_at_goal

meta def compute (l : parse location) : tactic unit :=
  match l with
  | loc.ns ll := ll.mmap' compute_at
  | loc.wildcard := tactic.local_context >>= list.mmap' (compute_at_hyp ∘ expr.local_pp_name)
  end
end tactic.interactive

notation `|`:1024 x:1 `|`:1 := abs x

lemma abs_inferieur_ssi (x y : ℝ) : |x| ≤ y ↔ -y ≤ x ∧ x ≤ y :=
abs_le

lemma abs_diff (x y : ℝ) : |x - y| = |y - x | :=
abs_sub _ _

variables {α : Type*} [decidable_linear_order α]
lemma superieur_max_ssi (p q r : α) : r ≥ max p q  ↔ r ≥ p ∧ r ≥ q :=
max_le_iff

lemma inferieur_max_gauche (p q : α) : p ≤ max p q :=
le_max_left _ _

lemma inferieur_max_droite (p q : α) : q ≤ max p q :=
le_max_right _ _

lemma egal_si_abs_diff_neg {a b : ℝ} : |a - b| ≤ 0 → a = b :=
decidable_linear_ordered_comm_group.eq_of_abs_sub_nonpos
-- Pour la lib
lemma egal_si_abs_eps (x y : ℝ) : (∀ ε > 0, |x - y| ≤ ε) → x = y :=
begin
  intro h,
  apply egal_si_abs_diff_neg,
  by_contradiction H,
  push_neg at H,
  specialize h ( |x-y|/2) (by linarith),
  linarith,
end

lemma ineg_triangle (x y : ℝ) : |x + y| ≤ |x| + |y| :=
abs_add x y

def limite_suite (u : ℕ → ℝ) (l : ℝ) : Prop :=
∀ ε > 0, ∃ N, ∀ n ≥ N, |u n - l| ≤ ε

-- Fait dans la feuille 5, à mettre dans 06_lib
lemma unicite_limite {u l l'}: limite_suite u l → limite_suite u l' → l = l' :=
begin
  -- sorry
  intros hl hl',
  apply egal_si_abs_eps,
  intros ε ε_pos,
  specialize hl (ε/2) (by linarith),
  cases hl with N hN,
  specialize hl' (ε/2) (by linarith),
  cases hl' with N' hN',
  specialize hN (max N N') (inferieur_max_gauche _ _),
  specialize hN' (max N N') (inferieur_max_droite _ _),
  calc |l - l'| = |(l-u (max N N')) + (u (max N N') -l')| : by compute
  ... ≤ |l - u (max N N')| + |u (max N N') - l'| : by apply ineg_triangle
  ... =  |u (max N N') - l| + |u (max N N') - l'| : by rw abs_diff
  ... ≤ ε/2 + ε/2 : by linarith
  ... = ε : by compute,
end


import data.real.basic
import data.real.nnreal

theorem exo (a b c: nnreal):
  (a^5 - a^2 + 3)(b^5 - b^2 + 3)(c^5 - c^2 + 3) >= (a+b+c)^3
:=
  sorry


open Classical

variable (α : Type) (p q : α → Prop)

variable (r : Prop)

example : (∃ x : α, r) → r := by
  intro ⟨y, hr⟩
  assumption

example (a : α) : r → (∃ x : α, r) := by
  intro hr
  constructor <;> assumption

example : (∃ x, p x ∧ r) ↔ (∃ x, p x) ∧ r := by
  constructor
  . intro h
    constructor
    . match h with
      | ⟨y, ⟨hp, _⟩⟩ => constructor <;> assumption
    . match h with
      | ⟨_, ⟨_, hr⟩⟩ => assumption
  . intro ⟨⟨y, hp⟩, hr⟩
    constructor; any_goals constructor; any_goals assumption

example : (∃ x, p x ∨ q x) ↔ (∃ x, p x) ∨ (∃ x, q x) := by
  constructor
  . intro
    | ⟨y, Or.inl hp⟩ => apply Or.inl; constructor <;> assumption
    | ⟨y, Or.inr hq⟩ => apply Or.inr; constructor <;> assumption
  . intro
    | Or.inl ⟨y, hp⟩ => exact ⟨y, Or.inl hp⟩
    | Or.inr ⟨y, hq⟩ => exact ⟨y, Or.inr hq⟩

example : (∀ x, p x) ↔ ¬ (∃ x, ¬ p x) := by
  constructor
  . intro h
    intro ⟨y, hhp⟩
    have hp := h y
    contradiction
  . intro h
    intro y
    apply byContradiction
    intro hnp
    exact h ⟨y, hnp⟩

example : (∃ x, p x) ↔ ¬ (∀ x, ¬ p x) := by
  constructor
  . intro ⟨x, hp⟩
    show ¬(∀ x, ¬ p x)
    intro hnp
    have hnp' := hnp x
    contradiction
  . intro h
    apply byContradiction
    intro h'
    have hnp : ∀ x, ¬ p x := by
      intro y
      match em (¬ p y) with
      | Or.inl hnp' => assumption
      | Or.inr hnnp =>
        have hp : p y := by
          apply byContradiction
          intro hnp'
          contradiction
        have h'' : ∃ x, p x := ⟨y, hp⟩
        contradiction
    contradiction

example : (¬ ∃ x, p x) ↔ (∀ x, ¬ p x) := by
  constructor
  . intro h
    intro y
    match em (p y) with
    | Or.inl hp =>
      have h' : ∃ x, p x := ⟨y, hp⟩
      contradiction
    | Or.inr hnp => assumption
  . intro hnp
    show ¬ ∃ x, p x
    intro ⟨y, hp⟩
    have hnp' := hnp y
    contradiction

example : (¬ ∀ x, p x) ↔ (∃ x, ¬ p x) := by
  constructor
  . intro h
    apply byContradiction
    intro h'
    have hn : ∀ x, p x := by
      intro y
      apply byContradiction
      intro hnp
      have hn' : ∃ x, ¬ p x := by constructor assumption
      contradiction
    contradiction
  . intro ⟨y, hnp⟩
    intro h'
    apply hnp
    apply h' y

example : (∀ x, p x → r) ↔ (∃ x, p x) → r := by
  constructor
  . intro h
    intro ⟨y, hp⟩
    have h' := h y
    apply h'
    assumption
  . intro h
    intro x
    intro hp
    apply h
    constructor; assumption

example (a : α) : (∃ x, p x → r) ↔ (∀ x, p x) → r := by
  constructor
  . intro ⟨x, h⟩
    intro h'
    exact h (h' x)
  . intro h
    match em (∀ x, p x) with
    | Or.inl h' =>
      have hr := h h'
      exists a
      intro _
      assumption
    | Or.inr h' =>
      apply byContradiction
      intro hn''
      have hp : ∀ x, p x := by
        intro y
        apply byContradiction
        intro hnp
        have h'' : ∃ x, p x → r := by
          exists y
          intro hp
          contradiction
        contradiction
      contradiction

example (a : α) : (∃ x, r → p x) ↔ (r → ∃ x, p x) := by
  constructor
  . intro ⟨x, h⟩
    intro hr
    constructor
    exact h hr
  . intro h
      match em r with
      | Or.inl hr =>
        match h hr with
        | ⟨y, hp⟩ =>
          exists y
          intro hr'
          assumption
      | Or.inr hnr =>
        exists a
        intro hr
        contradiction


import locally_constant.SemiNormedGroup
import normed_group.normed_with_aut
import analysis.normed.group.SemiNormedGroup.completion

/-!

# Completions of normed groups

This file contains an API for completions for seminormed groups equipped with
an automorphism which scales norms by a constant factor `r`.

## Main definitions

- `normed_with_aut_Completion` : if `V` is equipped with an automorphism changing norms
  by a factor `r` then the completion also has such an automorphism.
- `LCC : SemiNormedGroup ⥤ Profiniteᵒᵖ ⥤ SemiNormedGroup` :
  `LCC V S` is the seminormed group completion of the locally constant functions from `S` to `V`.

## TODO

Pull off the stuff about completions and put it into `normed_add_comm_group/SemiNormedGroup`?
Then `system_of_complexes.basic` would not have to import this file.

-/

noncomputable theory
open_locale nnreal

universe u

namespace SemiNormedGroup

open uniform_space _root_.opposite _root_.category_theory Completion

instance normed_with_aut_Completion (V : SemiNormedGroup.{u}) (r : ℝ≥0) [normed_with_aut r V] :
  normed_with_aut r (Completion.obj V) :=
{ T := Completion.map_iso normed_with_aut.T,
  norm_T :=
  begin
    rw ← function.funext_iff,
    refine abstract_completion.funext completion.cpkg _ _ _,
    { apply continuous_norm.comp _, exact completion.continuous_map },
    { exact (continuous_const.mul continuous_norm : _) },
    intro v,
    calc _ = _ : congr_arg norm (completion.map_coe _ _)
       ... = _ : _,
    { exact normed_add_group_hom.uniform_continuous _ },
    { erw [completion.norm_coe, normed_with_aut.norm_T, completion.norm_coe] }
  end }

@[simp] lemma Completion_T_inv_eq (V : SemiNormedGroup.{u}) (r : ℝ≥0) [normed_with_aut r V] :
  (normed_with_aut.T.hom : Completion.obj V ⟶ _) = Completion.map normed_with_aut.T.hom := rfl

lemma T_hom_incl {V : SemiNormedGroup} {r : ℝ≥0} [normed_with_aut r V] :
  (incl : V ⟶ _) ≫ normed_with_aut.T.hom = normed_with_aut.T.hom ≫ incl :=
begin
  ext x,
  simp only [incl_apply, category_theory.comp_apply, Completion_T_inv_eq],
  change completion.map normed_with_aut.T.hom _ = _,
  rw completion.map_coe,
  exact normed_add_group_hom.uniform_continuous _,
end

lemma T_hom_eq {V : SemiNormedGroup} {r : ℝ≥0} [normed_with_aut r V] :
  normed_with_aut.T.hom = Completion.lift ((normed_with_aut.T.hom : V ⟶ V) ≫ incl) :=
lift_unique _ _ T_hom_incl

/-- `LCC` (Locally Constant Completion) is the bifunctor
that sends a seminormed group `V` and a profinite space `S` to `V-hat(S)`.
Here `V-hat(S)` is the completion (for the sup norm) of the locally constant functions `S → V`. -/
def LCC : SemiNormedGroup ⥤ Profiniteᵒᵖ ⥤ SemiNormedGroup :=
curry.obj ((uncurry.obj LocallyConstant) ⋙ Completion)

lemma LCC_obj_map' (V : SemiNormedGroup) {X Y : Profiniteᵒᵖ} (f : Y ⟶ X) :
  (LCC.obj V).map f = Completion.map ((LocallyConstant.obj V).map f) :=
begin
  delta LCC,
  simp only [curry_obj_obj_map, LocallyConstant_obj_map, functor.comp_map, uncurry_obj_map,
    nat_trans.id_app, functor.map_comp, functor.map_id, category_theory.functor.map_id],
  erw [← functor.map_comp, category.id_comp]
end

lemma LCC_obj_map (V : SemiNormedGroup) {X Y : Profiniteᵒᵖ} (f : Y ⟶ X) (v : (LCC.obj V).obj Y) :
  (LCC.obj V).map f v = completion.map (locally_constant.comap f.unop) v :=
by { rw LCC_obj_map', refl }

lemma LCC_obj_map_norm_noninc (V : SemiNormedGroup) {X Y : Profiniteᵒᵖ} (f : Y ⟶ X) :
  ((LCC.obj V).map f).norm_noninc :=
begin
  rw LCC_obj_map',
  exact (Completion.map_norm_noninc $ LocallyConstant_obj_map_norm_noninc _ _ _ _)
end

variables (S : Type*) [topological_space S] [compact_space S]

@[simps]
instance normed_with_aut_LocallyConstant (V : SemiNormedGroup) (S : Profiniteᵒᵖ) (r : ℝ≥0)
  [normed_with_aut r V] [hr : fact (0 < r)] :
  normed_with_aut r ((LocallyConstant.obj V).obj S) :=
{ T := (LocallyConstant.map_iso normed_with_aut.T).app S,
  norm_T :=
  begin
    rw ← op_unop S,
    rintro (f : locally_constant (unop S : Profinite) V),
    show Sup _ = ↑r * Sup _,
    dsimp,
    simp only [normed_with_aut.norm_T],
    convert real.Sup_mul r _ hr.out,
    ext,
    simp only [exists_prop, set.mem_range, exists_exists_eq_and, set.mem_set_of_eq]
  end }

instance normed_with_aut_LCC (V : SemiNormedGroup) (S : Profiniteᵒᵖ) (r : ℝ≥0)
  [normed_with_aut r V] [hr : fact (0 < r)] :
  normed_with_aut r ((LCC.obj V).obj S) :=
show normed_with_aut r (Completion.obj $ (LocallyConstant.obj V).obj S), by apply_instance

end SemiNormedGroup

#lint- only unused_arguments def_lemma doc_blame


axiom let_in {A B} (x : A) (f : A -> B) : B
axiom add (x y : Nat) : Nat
@[simp] axiom addZero (x : Nat) : add x 0 = x
syntax "bigAdd0Seq! " num term:max : term
syntax "bigAddSeq! "  num term:max : term

macro_rules
  | `(bigAdd0Seq! $n $acc) =>
    let n := n.toNat
    if n == 0 then
      `(add $acc (add $acc 0))
    else
      `(let_in (add $acc (add $acc 0)) (fun acc' => bigAdd0Seq! $(Lean.quote (n - 1)) acc'))

macro_rules
  | `(bigAddSeq! $n $acc) =>
    let n := n.toNat
    if n == 0 then
      `(add $acc $acc)
    else
      `(let_in (add $acc $acc) (fun acc' => bigAddSeq! $(Lean.quote (n - 1)) acc'))

theorem ex1 (x : Nat) : bigAdd0Seq! 150 x = bigAddSeq! 150 x := by
  simp

-- theorem ex2 (x : Nat) : bigAddSeq! 5 x = bigAddSeq! 5 x := by
--   simp