import Lean.Elab.Tactic

set_option autoImplicit false

noncomputable section Theory    -- :)

open Classical

def Set (α : Type _) : Type _ :=
α → Prop

def Set.range' (n : Nat) : Set Nat :=
fun i => i ≤ n

def Nat.divides (a b : Nat) : Prop :=
∃ k, a * k = b

def Nat.prime (n : Nat) : Prop :=
n ≠ 1 ∧ ∀ a b, n.divides (a * b) → n.divides a ∨ n.divides b

def List.noDups {α : Type _} : List α → Prop
| [] => True
| (x :: xs) => x ∉ xs ∧ xs.noDups

def List.toSet {α : Type _} (l : List α) : Set α :=
fun x => x ∈ l

def List.sum : List Nat → Nat
| [] => 0
| (x :: xs) => x + xs.sum

def Set.finsum {α : Type _} (s : Set α) (f : α → Nat) : Nat :=
if h : ∃ (l : List α), l.noDups ∧ l.toSet = s
then ((choose h).map f).sum
else 0

def cite {α : Type _} (p : Prop) (x y : α) : α :=
if p then x else y

@[inherit_doc ite] syntax (name := termCIfThenElse)
  ppRealGroup(ppRealFill(ppIndent("cif " term " then") ppSpace term)
    ppDedent(ppSpace) ppRealFill("else " term)) : term

macro_rules
  | `(cif $c then $t else $e) => do
    let mvar ← Lean.withRef c `(?m)
    `(let_mvar% ?m := $c; wait_if_type_mvar% ?m; cite $mvar $t $e)

def Nat.sumPrimes (n : Nat) : Nat :=
(Set.range' n).finsum fun i => cif i.prime then i else 0

end Theory

section Computation

def Req {α : Type _} (x y : α) :=
x = y

def Riff (p : Prop) (q : Bool) := p ↔ (q = true)

def Rfun {α α' β β'} (R : α → β → Prop) (R' : α' → β' → Prop) : (α → α') → (β → β') → Prop :=
fun f g => ∀ ⦃a b⦄, R a b → R' (f a) (g b)

infixr:50 " ⇨ " => Rfun

def Nat.dividesImpl (a b : Nat) : Bool :=
if a == 0
  then b == 0
  else b == a * (b / a)

def Nat.primeImpl (n : Nat) : Bool :=
n > 1 ∧ ! n.any fun i => i > 1 ∧ i.dividesImpl n

axiom Nat.primeImplCorrect (n : Nat) :
  Riff n.prime n.primeImpl

axiom RprimeImpl : (Req ⇨ Riff) Nat.prime Nat.primeImpl

-- #eval ((List.range 100).filter Nat.primeImpl).length

--def Set.range'Impl₂ (n : Nat) : Impl (Set.range' n) (Nat → Bool) := fun i => i ≤ n

def RSetAsList {α : Type _} (x : Set α) (y : List α) : Prop :=
y.noDups ∧ y.toSet = x

def RSetAsFunBool {α : Type _} (x : Set α) (y : α → Bool) :=
∀ a, x a ↔ y a

def Rdepfun {α β : Type _} {α' : α → Type _} {β' : β → Type _}
  (R : α → β → Prop) (R' : (a : α) → (b : β) → α' a → β' b → Prop) : ((a : α) → α' a) → ((b : β) → β' b) → Prop :=
fun f g => ∀ ⦃a b⦄, R a b → R' a b (f a) (g b)

infixr:50 " ⇨ᵈ " => Rdepfun

theorem Rap {α α' β β'} {R : α → β → Prop} {R' : α' → β' → Prop}
  {f : α → α'} (g : β → β') {x : α} (y : β) :
  (R ⇨ R') f g → R x y → R' (f x) (g y) :=
fun h₁ h₂ => h₁ h₂

theorem RAP {Α Α' Β Β'} {r : Α → Β → Prop} {r' : Α' → Β' → Prop}
  {F : Α → Α'} (G : Β → Β') {X : Α} (Y : Β) :
  (r ⇨ r') F G → r X Y → r' (F X) (G Y) :=
fun H₁ H₂ => H₁ H₂

axiom Set.range'Impl₁ (n : Nat) : RSetAsList (Set.range' n) (List.range (n+1))

-- Use this in conjunction with ap rule for ⇒
-- axiom Set.finsumImpl : (RSetAsList ⇒ (Req ⇒ Req) ⇒ Req) (Set.finsum) (λ l g => l.map g |>.sum)
-- to derive the following:

axiom Set.finsumImpl {α : Type _} (s : Set α) (l : List α) (f : α → Nat) (g : α → Nat) :
  RSetAsList s l →
  (∀ j k, Req j k → Req (f j) (g k)) →      -- (Req ⇒ Req) f g
  Req (s.finsum f) (l.map g |>.sum)

theorem Set.finsumImpl₀ {α : Type _} :
  (RSetAsList ⇨ (Req ⇨ Req) ⇨ Req) (@Set.finsum (α := α)) (λ l g => l.map g |>.sum) :=
by
  intro s s' hs f f' hf
  apply Set.finsumImpl <;> assumption

theorem if_classical {p : Prop} {hp : Decidable p} [hp' : Decidable p] {α : Type _} (x y : α) :
  @ite α p hp x y = @ite α p hp' x y :=
by
  have : hp = hp' := Subsingleton.elim _ _
  rw [this]

axiom if_classical' {p : Prop} (p' : Prop) {hp : Decidable p} (hp' : Decidable p') {α : Type _} (x y : α) :
  (p ↔ p') →
  Req (if p then x else y) (if p' then x else y)

-- TODO: Generalize x, y to x', y' on RHS
-- axiom _ : (Riff ⇒ Req ⇒ Req ⇒ Req) ite (λ p' x y, if p' then x else y)
-- axiom _ {R} : (Riff ⇒ R ⇒ R ⇒ R) ite (λ p' x y, if p' then x else y)
axiom if_classical'' {p : Prop} (p' : Bool) {hp : Decidable p} {α : Type _} (x y : α) :
  Riff p p' →
  Req (if p then x else y) (if p' then x else y)

def id2 {α β} : (α → β) → α → β := id

def Rtriv (α β : Type _) (x : α) (y : β) : Prop := True

axiom Rcite {α β} {R : α → β → Prop} :
  (Riff ⇨ R ⇨ R ⇨ R) cite cond

def BLAH {α β} (f : (α → β) → Sort _) (x : α → β) : f (λ i => x i) → f x := id
def BLAH2 {α β} (f : β → Sort _) (y : α → β) (z : α) : f (y z) → f (y z) := id

def CHANGE (α) : α → α := id

--axiom if_classical₀ {α β} {R : α → β → Prop} :
--  (Riff ⇨ R ⇨ R ⇨ R) (open Classical in fun p x y => if p then x else y) (fun b x y => if b then x else y)

#print if_classical''

def Req.result {α : Type _} {x y : α} (_ : Req x y) : α := y

section

open Lean.Meta Lean.Elab.Tactic

elab "assign " n:term " => " e:term : tactic =>
  Lean.Elab.Tactic.withMainContext do
    match (← elabTerm n none) with
    | .mvar m => m.withContext do
      m.assign (← elabTerm e none)
      return ()
    | _ => return ()

end

def Nat.sumPrimesImpl₁ (n : Nat) : Nat :=
by
  have : Req (Nat.sumPrimes n) ?y1 :=
  by
    unfold Nat.sumPrimes
    -- TODO: megahack.
    -- Version that worked: explicitly write the correct formula in place of ?RESULT.
    -- Versions that didn't work: all others.
    refine' Rap (R := Req ⇨ Req) ?fx (?RESULT) ?rfx ?ry
    case rfx =>
      refine' Rap (R := RSetAsList) ?_ ?_ ?rf ?rx
      case rf => refine' Set.finsumImpl₀
      case rx => refine' Set.range'Impl₁ _
    case ry =>
      -- refine_to_fun RESULT
      -- assign ?RESULT => (fun j => (?RESULT' : ?_ → ?_) ?_)
      let M1 : Nat → Nat → Nat := fun j => cond (primeImpl j) j
      let M2 : Nat → Nat := fun j => j
      intro j j' hj
      dsimp only
      refine CHANGE (Req (cite (prime j) j 0) (M1 j' (M2 j'))) ?_
      set_option pp.all true in
      refine' Rap (R := Req) (R' := Req) _ _ ?rg ?rz₁
      case rg =>
        refine' Rap (R := Req) (R' := Req ⇨ Req) ?g₁ ?z₂ ?rg₁ ?rz₂
        case rg₁ =>
          refine' Rap ?_ ?_ ?rg₂ ?rz₃
          case rg₂ => exact Rcite
          case rz₃ =>
            refine' RprimeImpl ?_
            assumption
        case rz₂ =>
          assumption
      case rz₁ =>
        rfl
    -- refine Set.finsumImpl _ ?_ _ ?_ ?rs ?rf
    -- case rs =>
    --   refine Set.range'Impl₁ _
    -- case rf =>
    --   intro j k h
    --   subst h
    --   refine if_classical'' ?_ _ _ ?rp
    --   case rp =>
    --     refine (Nat.primeImplCorrect j)
  exact ?y1
  -- -- exact this.result

#eval Nat.sumPrimesImpl₁ 5
#print Nat.sumPrimesImpl₁

#exit

def Nat.sumPrimesImpl' (n : Nat) : Nat :=
by
  have : Req (Nat.sumPrimes n) ?y :=
  by
    unfold sumPrimes
    refine Set.finsumImpl _ ?_ _ ?_ ?rs ?rf
    case rs =>
      refine Set.range'Impl₁ _
    case rf =>
      intro j k h
      subst h
      refine if_classical'' ?_ _ _ ?rp
      case rp =>
        refine (Nat.primeImplCorrect j)
  exact ?y
  -- exact this.result

#print Nat.sumPrimesImpl'
#eval Nat.sumPrimesImpl' 5000

def Nat.sumPrimesImpl'' (n : Nat) : { y : Nat // Req (n.sumPrimes) y } :=
by
  refine ⟨?_, ?r⟩
  case r =>
    unfold sumPrimes
    refine Set.finsumImpl _ ?_ _ ?_ ?rs ?rf
    case rs =>
      refine Set.range'Impl₁ _
    case rf =>
      intro j k h
      subst h
      refine if_classical'' ?_ _ _ ?rp
      case rp =>
        refine (Nat.primeImplCorrect j)

abbrev Impl {α : Type _} (_a : α) : Type _ := α

def Impl.done {α : Type _} (a : α) : Impl a := a

def Nat.sumPrimesFun (n : Nat) : Nat :=
by
  have t : Impl (Nat.sumPrimesImpl'' n).val :=
  by
    dsimp only [Nat.sumPrimesImpl'']
    apply Impl.done
  exact t

def Nat.sumPrimesFun' (n : Nat) : Nat :=
by
  have : (Nat.sumPrimesImpl'' n).val = ?y :=
  by
    dsimp only [Nat.sumPrimesImpl'']
    exact rfl
  clear this
  exact ?y

theorem works (n : Nat) : Req n.sumPrimes n.sumPrimesFun' :=
(Nat.sumPrimesImpl'' n).property

#print Nat.sumPrimesFun'
#eval Nat.sumPrimesFun 500

end Computation


import analysis.inner_product_space.calculus
import analysis.inner_product_space.l2_space
import to_mathlib.analysis.calculus.affine_map
import to_mathlib.logic.equiv.local_equiv

variables {F : Type*} [normed_add_comm_group F] [normed_space ℝ F]

open set function metric affine_map
open_locale classical
noncomputable theory

namespace inner_product_space

variables {E : Type*} [normed_add_comm_group E] [inner_product_space ℝ E]

/-- Provided `0 < r`, this is a diffeomorphism from `E` onto the open ball of radius `r` in `E`
centred at a point `c` and sending `0` to `c`.

The values for `r ≤ 0` are junk.

TODO Refactor this: clearly it should really be built along the following lines:
```
variables (c : F) {r : ℝ} (hr : 0 < r)
include hr

def ball_homeomorph_ball : ball (0 : F) 1 ≃ₜ ball c r :=
{ to_fun := λ x, ⟨c +ᵥ homothety (0 : F) r (x : F), ...⟩,
  inv_fun := λ y, ⟨(homothety c r⁻¹ y) -ᵥ c, ...⟩,
  left_inv := ...,
  right_inv := ...,
  continuous_to_fun := ...,
  continuous_inv_fun := ..., }

-- Not quite the right type but nearly there:
#check (homeomorph_unit_ball.trans (ball_homeomorph_ball c hr)).to_local_homeomorph
```
 -/
def diffeomorph_to_nhd (c : E) (r : ℝ) :
  local_homeomorph E E :=
if hr : 0 < r then
{ to_fun := λ x, c +ᵥ homothety (0 : E) r (homeomorph_unit_ball x),
  inv_fun := (λ y, if hy : y ∈ ball (0 : E) 1 then homeomorph_unit_ball.symm ⟨y, hy⟩ else 0) ∘
    (λ y, (homothety c r⁻¹ y) -ᵥ c),
  source := univ,
  target := ball c r,
  open_source := is_open_univ,
  open_target := is_open_ball,
  map_source' := λ x _,
  begin
    have hx : ‖(homeomorph_unit_ball x : E)‖ < 1,
    { rw ← dist_zero_right, exact (homeomorph_unit_ball x).property, },
    rw [← mul_lt_mul_left hr, mul_one] at hx,
    simp only [homothety_apply, vsub_eq_sub, sub_zero, vadd_eq_add, add_zero, mem_ball,
      dist_self_add_left, norm_smul, real.norm_eq_abs, abs_eq_self.2 hr.le, hx],
  end,
  map_target' := λ x h, mem_univ _,
  left_inv' := λ x, by simp [homothety_apply, norm_smul, abs_eq_self.mpr hr.le, ← mul_assoc,
    ← smul_assoc, hr.ne.symm.is_unit.inv_mul_cancel],
  right_inv' := λ y hy,
  begin
    replace hy : r⁻¹ * ‖y - c‖ < 1,
    { rw [← mul_lt_mul_left hr, ← mul_assoc, mul_inv_cancel hr.ne.symm, mul_one, one_mul],
      simpa [dist_eq_norm] using hy, },
    simp [homothety_apply, norm_smul, abs_eq_self.2 hr.le, ← smul_assoc, mul_inv_cancel hr.ne.symm,
      hy],
  end,
  continuous_to_fun := continuous_iff_continuous_on_univ.mp $ continuous_const.add $
    (homothety_continuous 0 r).comp $ continuous_induced_dom.comp homeomorph_unit_ball.continuous,
  continuous_inv_fun :=
  begin
    refine continuous_on.comp _ (continuous.continuous_on _) (maps_to_homothety_ball c hr),
    { rw continuous_on_iff_continuous_restrict,
      convert homeomorph_unit_ball.symm.continuous, ext, simp, },
    { simp only [homothety_apply, vsub_eq_sub, vadd_eq_add, add_sub_cancel],
      exact continuous_const.smul (continuous_id.sub continuous_const), },
  end }
else local_homeomorph.refl E

@[simp] lemma diffeomorph_to_nhd_source (c : E) (r : ℝ) :
  (diffeomorph_to_nhd c r).source = univ :=
begin
  by_cases hr : 0 < r,
  { rw [diffeomorph_to_nhd, dif_pos hr], },
  { rw [diffeomorph_to_nhd, dif_neg hr, local_homeomorph.refl_local_equiv,
      local_equiv.refl_source], },
end

@[simp] lemma diffeomorph_to_nhd_apply_zero (c : E) {r : ℝ} (hr : 0 < r) :
  diffeomorph_to_nhd c r 0 = c :=
by simp only [diffeomorph_to_nhd, dif_pos hr, vadd_eq_add, local_homeomorph.mk_coe,
    local_equiv.coe_mk, coe_homeomorph_unit_ball_apply_zero, homothety_apply_same, add_zero]

@[simp] lemma range_diffeomorph_to_nhd_eq_ball (c : E) {r : ℝ} (hr : 0 < r) :
  range (diffeomorph_to_nhd c r) = ball c r :=
by erw [local_equiv.range_eq_target_of_source_eq_univ _ (diffeomorph_to_nhd_source c r),
    diffeomorph_to_nhd, dif_pos hr]

@[simp] lemma cont_diff_diffeomorph_to_nhd (c : E) (r : ℝ) {n : ℕ∞} :
  cont_diff ℝ n $ diffeomorph_to_nhd c r :=
begin
  by_cases hr : 0 < r,
  { rw [diffeomorph_to_nhd, dif_pos hr],
    exact cont_diff_const.add ((cont_diff_homothety 0 r).comp cont_diff_homeomorph_unit_ball), },
  { rw [diffeomorph_to_nhd, dif_neg hr],
    exact cont_diff_id, },
end

@[simp] lemma cont_diff_diffeomorph_to_nhd_inv (c : E) (r : ℝ) {n : ℕ∞} :
  cont_diff_on ℝ n (diffeomorph_to_nhd c r).symm (diffeomorph_to_nhd c r).target :=
begin
  by_cases hr : 0 < r,
  { rw [diffeomorph_to_nhd, dif_pos hr],
    have aux : ball c r ⊆ (λ (x : E), (λ (y : E), homothety c r⁻¹ y -ᵥ c) x) ⁻¹' (ball 0 1) :=
      maps_to_homothety_ball c hr,
    refine cont_diff_on.comp _ (cont_diff.cont_diff_on _) aux,
    { exact cont_diff_on_homeomorph_unit_ball_symm (λ y hy, dif_pos hy), },
    { simp only [homothety_apply, vsub_eq_sub, vadd_eq_add, add_sub_cancel],
      exact cont_diff_const.smul (cont_diff_id.sub cont_diff_const), }, },
  { rw [diffeomorph_to_nhd, dif_neg hr],
    exact cont_diff_on_id, },
end

end inner_product_space

variables (F) [finite_dimensional ℝ F]

/-- The Euclidean space obtained by choosing a basis of `F` and declaring it to be orthnormal.  -/
def l2 := euclidean_space ℝ $ basis.of_vector_space_index ℝ F

instance : normed_add_comm_group (l2 F) := pi_Lp.normed_add_comm_group 2 _
instance : inner_product_space ℝ (l2 F) := pi_Lp.inner_product_space _

/-- The continuous linear equivalence from `F` with its given norm to itself with the Euclidean
norm obtained from a choice of basis. -/
def self_equiv_l2 : F ≃L[ℝ] l2 F :=
linear_equiv.to_continuous_linear_equiv
  ((basis.of_vector_space ℝ F).equiv_fun.trans
    (euclidean_space.equiv (basis.of_vector_space_index ℝ F) ℝ).symm.to_linear_equiv)

-- We shouldn't really need this lemma.
@[simp] lemma self_equiv_l2_image_univ :
  self_equiv_l2 F '' univ = univ :=
begin
  rw image_univ,
  exact (self_equiv_l2 F : F ≃ l2 F).range_eq_univ,
end

variables {F}

/-- A variant of `inner_product_space.diffeomorph_to_nhd` which provides a function satisfying the
weaker condition `range_diffeomorph_to_nhd_subset_ball` but which applies to any `normed_space`.

In fact one could demand this stronger property but it would be more work and we don't need it. -/
def diffeomorph_to_nhd (c : F) (r : ℝ) :
  local_homeomorph F F :=
if hr : 0 < r then
begin
  let B := (self_equiv_l2 F) '' (ball c r),
  let f := (self_equiv_l2 F).to_homeomorph,
  have hB : is_open B := f.is_open_map _ is_open_ball,
  have hc : self_equiv_l2 F c ∈ B := mem_image_of_mem f (mem_ball_self hr),
  let ε := classical.some (metric.is_open_iff.mp hB _ hc),
  exact (f.trans_local_homeomorph (inner_product_space.diffeomorph_to_nhd
    (self_equiv_l2 F c) ε)).trans_homeomorph f.symm,
end
else local_homeomorph.refl F

@[simp] lemma diffeomorph_to_nhd_source (c : F) (r : ℝ) :
  (diffeomorph_to_nhd c r).source = univ :=
begin
  by_cases hr : 0 < r,
  { simp [diffeomorph_to_nhd, dif_pos hr], },
  { rw [diffeomorph_to_nhd, dif_neg hr, local_homeomorph.refl_local_equiv,
      local_equiv.refl_source], },
end

@[simp] lemma diffeomorph_to_nhd_apply_zero (c : F) {r : ℝ} (hr : 0 < r) :
  diffeomorph_to_nhd c r 0 = c :=
begin
  rw [diffeomorph_to_nhd, dif_pos hr],
  let B := (self_equiv_l2 F) '' (ball c r),
  let f := (self_equiv_l2 F).to_homeomorph,
  have hB : is_open B := f.is_open_map _ is_open_ball,
  have hc : self_equiv_l2 F c ∈ B := mem_image_of_mem f (mem_ball_self hr),
  let ε := classical.some (metric.is_open_iff.mp hB _ hc),
  have hε : 0 < ε := classical.some (classical.some_spec (metric.is_open_iff.mp hB _ hc)),
  change (f.trans_local_homeomorph (inner_product_space.diffeomorph_to_nhd
    (self_equiv_l2 F c) ε)).trans_homeomorph f.symm 0 = c,
  simp [hε],
end

@[simp] lemma range_diffeomorph_to_nhd_subset_ball (c : F) {r : ℝ} (hr : 0 < r) :
  range (diffeomorph_to_nhd c r) ⊆ ball c r :=
begin
  rw [diffeomorph_to_nhd, dif_pos hr, ← image_univ],
  let B := (self_equiv_l2 F) '' (ball c r),
  let f := (self_equiv_l2 F).to_homeomorph,
  have hB : is_open B := f.is_open_map _ is_open_ball,
  have hc : self_equiv_l2 F c ∈ B := mem_image_of_mem f (mem_ball_self hr),
  let ε := classical.some (metric.is_open_iff.mp hB _ hc),
  have hε : 0 < ε := classical.some (classical.some_spec (metric.is_open_iff.mp hB _ hc)),
  have hε' : ball (self_equiv_l2 F c) ε ⊆ B :=
    classical.some_spec (classical.some_spec (metric.is_open_iff.mp hB _ hc)),
  change f.symm ∘ (inner_product_space.diffeomorph_to_nhd (self_equiv_l2 F c) ε ∘ f) '' univ ⊆ _,
  rw [image_comp f.symm _, image_comp _ f],
  erw [self_equiv_l2_image_univ, image_univ,
    inner_product_space.range_diffeomorph_to_nhd_eq_ball _ hε],
  suffices : ball c r = f.symm '' (f '' ball c r), { rw this, exact monotone_image hε', },
  rw ← image_comp,
  simp,
end

@[simp] lemma cont_diff_diffeomorph_to_nhd (c : F) (r : ℝ) {n : ℕ∞} :
  cont_diff ℝ n $ diffeomorph_to_nhd c r :=
begin
  by_cases hr : 0 < r,
  { rw [diffeomorph_to_nhd, dif_pos hr],
    exact (self_equiv_l2 F).symm.cont_diff.comp
      ((inner_product_space.cont_diff_diffeomorph_to_nhd _ _).comp (self_equiv_l2 F).cont_diff), },
  { rw [diffeomorph_to_nhd, dif_neg hr],
    exact cont_diff_id, },
end

@[simp] lemma cont_diff_diffeomorph_to_nhd_inv (c : F) (r : ℝ) {n : ℕ∞} :
  cont_diff_on ℝ n (diffeomorph_to_nhd c r).symm (diffeomorph_to_nhd c r).target :=
begin
  by_cases hr : 0 < r,
  { rw [diffeomorph_to_nhd, dif_pos hr],
    refine cont_diff_on.comp_continuous_linear_map _ (self_equiv_l2 F : F →L[ℝ] l2 F),
    refine (self_equiv_l2 F).symm.cont_diff.comp_cont_diff_on _,
    exact inner_product_space.cont_diff_diffeomorph_to_nhd_inv _ _, },
  { rw [diffeomorph_to_nhd, dif_neg hr],
    exact cont_diff_on_id, },
end


-- Copyright (C) 2020 by @ljt12138

import tactic pal.proof pal.basics pal.lemmas pal.dynamic

namespace pal_logic

/-----------------------------------------------------------------------
 -                          Henkin Model                               -
 -----------------------------------------------------------------------

  The Henkin model for modal logic is the tuple (W, ∼ᵢ, s, Vₛ), where
 1. W is all maximal consistent set;
 2. u ∼ᵢ v iff for all □ᵢφ ∈ u, we have φ ∈ v;
 3. s ∈ W is current world;
 4. Vₛ ⊨ φ iff φ ∈ s.

  Since we are using type inside of set, we will call a set of sentences
a decider, and call a maximal consistent set a consistent decider. The
following lemmas give some properties of consistent decider.
 - decide_mp :: if (φ→ψ) ∈ Δ and φ ∈ Δ, then ψ ∈ Δ
 - decide_not_iff_not_decide :: φ ∉ Δ iff ¬φ ∈ Δ
 - decide_tauto :: if φ is a tautology, φ ∈ Δ
 - decide_and_iff_and_decide :: φ∧ψ ∈ Δ iff φ ∈ Δ and ψ ∈ Δ
 - decide_useless_condition :: if ψ ∈ Δ, then φ→ψ ∈ Δ
 - decide_false_condition :: if φ ∉ Δ, then φ→ψ ∈ Δ

  These lemmas are used to show that the Henkin model is actually a
model for modal logic S5, that is reflexive, transitive and symmetric.

  The only hard part remained for our main theorem
                     φ ∈ s   iff   (M, s) ⊨ φ
is to deal with the case (φ = □ᵢψ). If (M, s) ⊨ φ holds, it is not
trivial that φ ∈ s holds. We will prove this as following: consider the
set of sentences Δ = {¬ψ} ∪ {α | □ᵢα ∈ s}.
 1. If Δ is inconsistent, we know that there exists α₁ α₂ ... αₙ ∈ Δ
    such that α₁∧α₂∧...∧αₙ∧¬ψ → ⊥ is provable, hence
                            ∧ₖαₖ → ψ
    is also provable. By axiom we have □ᵢ(∧ₖαₖ → ψ) provable, by
    modality distribution we have □ᵢ(∧ₖαₖ) → □ᵢψ provable. Since αₖ ∈ Δ,
    by definition we have □ᵢαₖ ∈ s for every k, by decide_mp we know that
                          φ = □ᵢψ ∈ s.
 2. If Δ is consistent, assume that everything is encodable, we may extend
    it to a consistent decider t (this is the Main Lemma we need). Then,
    we will see that s ∼ᵢ t by definition, but ¬ψ ∈ t, contradiction to
    (M, s) ⊨ □ᵢψ.

  The Main Lemma will be explained more clearly in section 3.
-/

/-               ---- 1. Definitions and Lemmas ----                    -/

def decider (α agent : Type) := sentence α agent → Prop
@[simp] def consistent_set {α agent : Type} (d : decider α agent) :=
  (∀ Γ : list (sentence α agent), (∀ φ, φ∈Γ → d φ) → ¬ ⊢ conjunction Γ ↣ ⊥)
@[simp] def consistent_decider {α agent : Type} (d : decider α agent) :=
  consistent_set d ∧ ∀ φ, d φ ∨ d (φ↣⊥)

inductive decider_world (α agent : Type) : Type
| mk (d : decider α agent) : consistent_decider d → decider_world
@[simp] def decides {α agent : Type} : decider_world α agent → sentence α agent → Prop
| (decider_world.mk d h) φ := d φ

lemma decide_mp {α agent : Type} (d : decider_world α agent) :
  ∀ φ ψ, decides d (φ↣ψ) → decides d φ → decides d ψ :=
begin
  intros φ ψ a₁ a₂, classical,
  by_contra a₃, cases d with d h, simp at *,
  have h₁ : d (ψ↣⊥), { cases h.right ψ, exfalso, exact a₃ h_1, assumption },
  have h₂ := h.left [ψ↣⊥,φ↣ψ,φ],
  apply h₂,
  {
    intros, simp at a, cases a,
    rewrite a, assumption, cases a,
    repeat {rewrite a, assumption}
  },
  unfold conjunction,
  have hψ : ⊢ (ψ↣⊥) & (φ↣ψ) & φ ↣ ψ,
  {
    existsi proof.conjr _ _ _, apply proof_of.conjr,
    apply proof_of.conjmp
  },
  have hnψ : ⊢ (ψ↣⊥) & (φ↣ψ) & φ ↣ (ψ↣⊥),
  {
    have ht := id_provable (ψ↣⊥), cases ht,
    existsi proof.conjl _ _ _, prover
  },
  have hax : ⊢ Ax2 ((ψ↣⊥)&(φ↣ψ)&φ) ψ ⊥, { existsi proof.ax2 _ _ _, prover },
  cases hax, cases hψ, cases hnψ,
  existsi proof.mp (proof.mp _ _) _, prover
end

lemma decide_not_iff_not_decide {α agent : Type} (d : decider_world α agent) :
  ∀ φ, ¬ decides d φ ↔ decides d (φ ↣ ⊥) :=
begin
  intros φ, split, classical,
  {
    intros a₁, by_contra a₂,
    cases d with d h,
    cases h.right φ, exact a₁ h_1, exact a₂ h_1
  },
  {
    intros a₁ a₂,
    have h₁ := decide_mp _ _ _ a₁ a₂,
    cases d with d h₂,
    simp at h₂, apply (h₂.left [⊥]),
    simp, assumption, simp, apply id_provable
  }
end

lemma decide_tauto {α agent : Type} (d : decider_world α agent) :
  ∀ φ, ⊢ φ → decides d φ :=
begin
  intros φ a₁, classical, by_contra a₂,
  have ht := (decide_not_iff_not_decide d φ).mp a₂,
  cases d with d h,
  apply h.left [φ↣⊥], simp, assumption,
  simp, cases a₁,
  have ht' := dni φ, cases ht',
  existsi proof.mp _ _, prover
end

lemma decide_and_iff_and_decide {α agent : Type} (d : decider_world α agent) :
  ∀ φ ψ, decides d (φ & ψ) ↔ decides d φ ∧ decides d ψ :=
begin
  intros φ ψ, classical, split,
  {
    intros a, split,
    have h₁ : decides d ((φ & ψ)↣φ),
    { apply decide_tauto, apply uncurry, existsi proof.ax1 _ _, prover },
    apply decide_mp, repeat {assumption},
    have h₂ : decides d ((φ & ψ)↣ψ),
    { apply decide_tauto, apply uncurry, apply useless_condition, apply id_provable},
    apply decide_mp, repeat {assumption}
  },
  {
    intros,
    have h₁ : decides d (φ↣ψ↣φ&ψ),
    { apply decide_tauto, apply curry, apply id_provable },
    apply decide_mp, apply decide_mp, assumption, repeat {tauto}
  }
end

lemma decide_useless_condition {α agent : Type} (d : decider_world α agent) :
  ∀ φ ψ, decides d φ → decides d (ψ ↣ φ) :=
begin
  intros φ ψ a,
  apply decide_mp,
  { apply decide_tauto, existsi proof.ax1 _ _, prover },
  { assumption }
end

lemma decide_false_condition {α agent : Type} (d : decider_world α agent) :
  ∀ φ ψ, ¬ decides d φ → decides d (φ↣ψ) :=
begin
  intros φ ψ a,
  have h₁ : decides d (φ↣⊥),
  {
    cases d with d h, cases h.right φ,
    { simp at *, exfalso, exact a h_1 },
    { simp, assumption }
  },
  have h₂ : decides d (φ↣⊥↣ψ),
  {
    apply decide_useless_condition,
    apply decide_tauto,
    apply explosion
  },
  have h₃ : decides d (Ax2 φ ⊥ ψ),
  {
    apply decide_tauto,
    existsi proof.ax2 _ _ _, prover
  },
  unfold Ax2 at h₃,
  apply decide_mp, apply decide_mp, repeat {assumption}
end

/-           ----2. Access relation ∼ᵢ and Henkin Model----              -/

@[simp] def access {α agent : Type} (i : agent) (s t : decider_world α agent) :=
  ∀ φ : sentence α agent, decides s □(i:φ) → decides t φ

notation s `∼{` i `}` t := access i s t

@[refl]
lemma access.reflexive {α agent : Type} (i : agent) (s t : decider_world α agent) :
  s ∼{i} s :=
begin
  simp, intros φ a,
  apply decide_mp,
  { apply decide_tauto, existsi proof.ref _ _, apply proof_of.ref, exact i },
  { assumption }
end

@[trans]
lemma access.transitive {α agent : Type} (i : agent) (s t₁ t₂ : decider_world α agent) :
  (s ∼{i} t₁) → (t₁ ∼{i} t₂) → (s ∼{i} t₂) :=
begin
  simp, intros a₁ a₂,
  intros φ a₃, apply a₂, apply a₁,
  apply decide_mp,
  { apply decide_tauto, existsi proof.trans _ _, apply proof_of.trans },
  { assumption }
end

@[symm]
lemma access.symmetric {α agent : Type} (i : agent) (s t : decider_world α agent) :
  (s ∼{i} t) → (t ∼{i} s) :=
begin
  simp, intros a₁ φ a₂,
  have h₁ : decides s (□(i:φ)) ∨ decides s (□(i:φ)↣⊥),
  { cases s with s h, cases h.right _, left, assumption, right, assumption },
  cases h₁,
  {
    apply decide_mp, apply decide_tauto,
    existsi proof.ref _ _, apply proof_of.ref, exact i,
    assumption
  },
  {
    exfalso,
    have h₂ : decides s (□(i:□(i:φ)↣⊥)),
    {
      apply decide_mp, apply decide_tauto,
      existsi proof.sym _ _, apply proof_of.sym, assumption
    },
    have h₃ := a₁ _ h₂,
    have h₄ : decides t ⊥,
    { apply decide_mp, assumption, assumption },
    cases t with t h,
    apply h.left [⊥], simp, assumption,
    simp, apply id_provable
  }
end

@[simp]
def henkin_worlds (α agent : Type) : worlds α agent (decider_world α agent) :=
{
  f := λ s a, decides s ⟦a⟧,
  view := access,
  equiv :=
  begin
    intros i, unfold equivalence reflexive symmetric transitive, split,
    { intros, apply access.reflexive, exact x }, split,
    { intros x y, apply access.symmetric },
    { intros x y z, apply access.transitive }
  end
}

@[simp]
def henkin_model {α agent : Type} (s : decider_world α agent) :=
  (henkin_worlds α agent, s)

notation `⦃` s `⦄` := henkin_model s

/-              ----3. Encoding and Complete Extension----            -/

-- Here we explicitly gives an encoding of sentences,
--  provided that both α and agent are encodable
@[simp]
def enc {α agent : Type} (f : α → ℕ) (g : agent → ℕ) : sentence α agent → ℕ
| ⟦p⟧              := (nat.mkpair 1 (f p)) + 1
| ⊥                := (nat.mkpair 2 0) + 1
| (φ↣ψ)            := (nat.mkpair 3 (nat.mkpair (enc φ) (enc ψ))) + 1
| □(i : φ)         := (nat.mkpair 4 (nat.mkpair (g i) (enc φ))) + 1
| [!φ]ψ            := (nat.mkpair 5 (nat.mkpair (enc φ) (enc ψ))) + 1

@[simp]
def dec {α agent : Type} (f' : ℕ → option α) (g' : ℕ → option agent)
    : ℕ → option (sentence α agent)
| 0     := none
| (n+1) := have h₁ : n.unpair.snd < n+1 :=
             calc n.unpair.snd ≤ n   : nat.unpair_le_right _
                  ...          < n+1 : by simp,
           have h₂ : n.unpair.snd.unpair.fst < n+1 :=
             calc n.unpair.snd.unpair.fst ≤ n.unpair.snd : nat.unpair_le_left _
                  ...                     ≤ n            : nat.unpair_le_right _
                  ...                     < n+1          : by simp,
           have h₃ : n.unpair.snd.unpair.snd < n+1 :=
             calc n.unpair.snd.unpair.snd ≤ n.unpair.snd : nat.unpair_le_right _
                  ...                     ≤ n            : nat.unpair_le_right _
                  ...                     < n+1          : by simp,
           let op := n.unpair.fst,
               v  := n.unpair.snd in
               match op with
               | 1 := match (f' v) with
                      | some p := some ⟦p⟧
                      | none   := none
                      end
               | 2 := match v with
                      | 0      := some ⊥
                      | _      := none
                      end
               | 3 := let eφ := v.unpair.fst,
                          eψ := v.unpair.snd in
                          match dec eφ, dec eψ with
                          | none, _     := none
                          | _, none     := none
                          | some φ, some ψ := some (φ ↣ ψ)
                          end
               | 4 := let ei := v.unpair.fst,
                          eφ := v.unpair.snd in
                          match g' ei, dec eφ with
                          | none, _     := none
                          | _, none     := none
                          | some i, some φ := some □(i : φ)
                          end
               | 5 := let eφ := v.unpair.fst,
                          eψ := v.unpair.snd in
                          match dec eφ, dec eψ with
                          | none, _     := none
                          | _, none     := none
                          | some φ, some ψ := some [!φ]ψ
                          end
               | _ := none
               end

@[instance]
lemma sentence_encodable {α agent : Type} :
  encodable α → encodable agent → encodable (sentence α agent) :=
begin
  intros enc₁ enc₂,
  cases enc₁ with f f' h₁,
  cases enc₂ with g g' h₂,
  have h₃ : ∀ φ : sentence α agent,
              dec f' g' (enc f g φ) = some φ,
  {
    intros φ, induction φ,
    { simp, rewrite h₁, simp },
    { simp  },
    { simp, rewrite φ_ih_a, rewrite φ_ih_a_1, simp },
    { simp, rewrite φ_ih, rewrite h₂, simp },
    { simp, rewrite φ_ih_a, rewrite φ_ih_a_1, simp }
  },
  split, { exact h₃ }
end

private def ext {α agent : Type} (d : decider α agent) (φ : sentence _ _) :=
  λ ψ, ψ = φ ∨ d ψ

lemma ext_origin {α agent : Type} {d : decider α agent} {φ : sentence α agent} :
  ∀ ψ, d ψ → (ext d φ) ψ :=
begin
  intros, right, exact a
end

lemma ext_new {α agent : Type} {d : decider α agent} {φ : sentence α agent} :
  ext d φ φ :=
begin
  left, refl
end

-- firstly, show that Δ ∪ {φ} ⊢ ⊥ implies that Δ ⊢ ¬φ,
--  then, in the case ¬φ ∈ Γ and φ ∈ Γ', we have Δ ⊢ φ and Δ ⊢ ¬φ, hence Δ ⊢ ⊥,
--  contradiction

private def single_extend {α agent : Type} (d : decider α agent) (φ : sentence _ _) :=
begin
  classical,
  exact if (consistent_set (ext d φ)) then ext d φ else ext d (φ ↣ ⊥)
end

private def henkin_enum {α agent : Type} [encodable (sentence α agent)]
        (d₀ : decider α agent) : ℕ → decider α agent
| 0         := d₀
| (n + 1)   := let d := henkin_enum n in
                 match encodable.decode (sentence α agent) n with
                 | none        := d
                 | some φ      := single_extend d φ
                 end

lemma extend_preserve {α agent : Type} (d : decider α agent) (φ ψ : sentence _ _) :
  d ψ → consistent_set d → single_extend d φ ψ :=
begin
  intros h₁ h₂,
  cases em (consistent_set (ext d φ)),
  {
    simp [single_extend, h], cases em (φ = ψ),
    { rewrite h_1, apply ext_new },
    { apply ext_origin, exact h₁ }
  },
  {
    simp [single_extend, h], cases em (φ↣⊥ = ψ),
    { rewrite h_1, apply ext_new },
    { apply ext_origin, exact h₁ }
  }
end

lemma extend_new {α agent : Type} (d : decider α agent) (φ : sentence _ _) :
  single_extend d φ φ ∨ single_extend d φ (φ↣⊥) :=
begin
  cases em (consistent_set (ext d φ)),
  { simp [single_extend, h], left, apply ext_new },
  { simp [single_extend, h], right, apply ext_new }
end

lemma dsingle_extension {α agent : Type} (d : decider α agent) (φ : sentence _ _) :
  consistent_set d → let d' := single_extend d φ
    in consistent_set d' ∧ (∀ ψ, d ψ → d' ψ) ∧ (d' φ ∨ d' (φ↣⊥)) :=
begin
  intros h₁,
  cases classical.em (consistent_set (ext d φ)),
  { -- d ∪ {φ} is consistent
    split,
    { simp [single_extend, h], exact h },
    {
      simp [single_extend, h, ext], split,
      { intros ψ h', right, exact h' },
      { left, left, refl }
    }
  },
  { -- d ∪ {φ} is inconsistent
    split,
    {
      simp [single_extend, h₁, h],
      intros Γ h₂ contra₁,
      apply h, intros Γ' h₃ contra₂,
      cases em (φ↣⊥ ∈ Γ),
      {
        cases em (φ ∈ Γ'),
        {
          cases contra_imp_conseq h_1 contra₁ with Γ₁,
          cases contra_imp_conseq h_2 contra₂ with Γ₂,
          apply h₁ (Γ₁++Γ₂),
          {
            intros ψ ht, simp at ht, cases ht,
            {
              cases h₂ ψ (h_3.left ht),
              rewrite h_5 at *, exfalso, exact h_3.right.left ht, exact h_5
            },
            {
              cases h₃ ψ (h_4.left ht),
              rewrite h_5 at *, exfalso, exact h_4.right.left ht, exact h_5
            }
          },
          have ht₁ : Γ₁ ⊆ Γ₁ ++ Γ₂ := by simp,
          have ht₂ : Γ₂ ⊆ Γ₁ ++ Γ₂ := by simp,
          cases conj_subset h_3.right.right ht₁,
          cases conj_subset h_4.right.right ht₂,
          existsi proof.mp (proof.mp (proof.ax2 _ _ _) _) _,
          prover
        },
        {
          fapply h₁, exact Γ',
          intros ψ h₄,
          have ht := h₃ ψ h₄, simp [ext] at ht, cases ht,
          { exfalso, apply h_2, rewrite ← ht, exact h₄ },
          { exact ht },
          exact contra₂
        }
      },
      {
        fapply h₁, exact Γ,
        intros ψ h₄,
        have ht := h₂ ψ h₄, simp [ext] at ht, cases ht,
        { exfalso, apply h_1, rewrite ← ht, exact h₄ },
        { exact ht },
        exact contra₁
      }
    },
    {
      simp [single_extend, h], split,
      { apply ext_origin },
      { right, apply ext_new }
    }
  }
end

private def prefix_decider {α agent : Type} [encodable (sentence α agent)]
  (d : decider α agent) (n : ℕ) := ∀ φ, encodable.encode φ < n →  d φ ∨ d (φ ↣ ⊥)

lemma henkin_enum_consistent {α agent : Type} [encodable (sentence α agent)]
  (d₀ : decider α agent) (h : consistent_set d₀) (n : ℕ) :
    consistent_set (henkin_enum d₀ n) :=
begin
  induction n with n ih,
  { exact h },
  {
    unfold henkin_enum,
    have ht : ∃ pφ, pφ = encodable.decode (sentence α agent) n,
    { existsi _, refl },
    cases ht with φ ref, rewrite ← ref, cases φ,
    { simp [henkin_enum], exact ih },
    { simp [henkin_enum], exact (dsingle_extension _ φ ih).left }
  }
end

lemma henkin_enum_prefix {α agent : Type} [encodable (sentence α agent)]
  (d₀ : decider α agent) (h : consistent_set d₀) (n : ℕ) :
    prefix_decider (henkin_enum d₀ n) n :=
begin
  induction n with n ih,
  { simp [prefix_decider, henkin_enum] },
  {
    simp [prefix_decider, henkin_enum],
    have ht : ∃ pφ, pφ = encodable.decode (sentence α agent) n,
    { existsi _, refl },
    cases ht with pφ ref, rewrite ← ref, cases pφ with φ,
    { -- [φ] = n
      simp [henkin_enum], intros ψ a,
      have ht : encodable.encode ψ ≤ n := by omega,
      cases lt_or_eq_of_le ht with h₁ h₁,
      { apply ih, exact h₁ },
      { rewrite ← h₁ at ref, simp at ref, exfalso, exact ref }
    },
    { -- [φ] < n
      simp [henkin_enum], intros ψ a,
      have ht : encodable.encode ψ ≤ n := by omega,
      cases lt_or_eq_of_le ht with h₁ h₁,
      {
        unfold prefix_decider at ih,
        cases ih ψ h₁ with h₂ h₂,
        {
          left, apply extend_preserve, exact h₂,
          apply henkin_enum_consistent, exact h,
        },
        {
          right, apply extend_preserve, exact h₂,
          apply henkin_enum_consistent, exact h
        }
      },
      {
        rewrite ← h₁ at ref, simp at ref, rewrite ref,
        apply extend_new
      }
    }
  }
end

lemma henkin_enum_subset {α agent : Type} [encodable (sentence α agent)]
  (d₀ : decider α agent) (h : consistent_set d₀) (n m : ℕ) (φ : sentence α agent) :
    (n ≤ m) → (henkin_enum d₀ n) φ → (henkin_enum d₀ m) φ :=
begin
  intros h₁ h₂,
  induction m with m ih,
  { have ht : n = 0 := by omega, rewrite ht at h₂, exact h₂ },
  {
    cases lt_or_eq_of_le h₁ with h₃ h₃,
    {
      simp [henkin_enum],
      have ht : ∃ pφ, pφ = encodable.decode (sentence α agent) m,
      { existsi _, refl },
      cases ht with pφ h₃, rewrite ← h₃, cases pφ with ψ,
      { simp [henkin_enum], apply ih, omega},
      {
        simp [henkin_enum], apply extend_preserve, apply ih, omega,
        apply henkin_enum_consistent, exact h
      }
    },
    { rewrite ← h₃, exact h₂ }
  }
end

lemma henkin_enum_em {α agent : Type} [encodable (sentence α agent)]
  (d₀ : decider α agent)(φ : sentence α agent) :
    henkin_enum d₀ (encodable.encode φ + 1) φ
      ∨ henkin_enum d₀ (encodable.encode φ + 1) (φ↣⊥) :=
begin
  simp [henkin_enum],
  cases em (consistent_set (ext (henkin_enum d₀ (encodable.encode φ)) φ)),
  { simp [single_extend, h], left, apply ext_new },
  { simp [single_extend, h], right, apply ext_new }
end

def henkin_union {α agent : Type} [encodable (sentence α agent)]
  (d₀ : decider α agent) (φ : sentence α agent) :=
    henkin_enum d₀ ((encodable.encode φ) + 1) φ

lemma henkin_union_subset {α agent : Type} [encodable (sentence α agent)]
  (d₀ : decider α agent) (h : consistent_set d₀) (φ : sentence _ _) :
    d₀ φ → henkin_union d₀ φ :=
begin
  intros h₁, unfold henkin_union,
  apply henkin_enum_subset _ h 0, simp,
  simp [henkin_enum], exact h₁
end

def maximum_encoding {α agent : Type} [encodable (sentence α agent)]
  : list (sentence α agent) → ℕ
| []     := 0
| (φ::Γ) := max (encodable.encode φ + 1) (maximum_encoding Γ)

lemma henkin_union_Γ {α agent : Type} [encodable (sentence α agent)]
  (d₀ : decider α agent) (h : consistent_set d₀) (Γ : list (sentence α agent)) :
    (∀ φ, φ ∈ Γ → henkin_union d₀ φ) →
    (∀ φ, φ ∈ Γ → henkin_enum d₀ (maximum_encoding Γ) φ) :=
begin
  intros h₁ φ h₂,
  induction Γ with ψ Γ ih,
  { simp at h₂, exfalso, exact h₂ },
  {
    simp [maximum_encoding], simp at h₂, cases h₂,
    {
      rewrite h₂ at *,
      have ht := h₁ ψ (list.mem_cons_self _ _), simp [henkin_union] at ht,
      apply henkin_enum_subset, exact h, apply le_max_left, exact ht
    },
    {
      apply henkin_enum_subset, exact h, apply le_max_right, apply ih,
      intros ρ h₃, apply h₁, simp, right, exact h₃, exact h₂
    }
  }
end

lemma henkin_union_consistent {α agent : Type} [encodable (sentence α agent)]
  (d₀ : decider α agent) (h : consistent_set d₀) :
    consistent_set (henkin_union d₀) :=
begin
  intros Γ h₁ contra,
  apply (henkin_enum_consistent d₀ h),
  apply henkin_union_Γ, exact h,
  exact h₁, exact contra
end

lemma henkin_enum_agree {α agent : Type} [encodable (sentence α agent)]
  (d₀ : decider α agent) (h : consistent_set d₀) (φ : sentence α agent) (n : ℕ) :
    henkin_enum d₀ n φ → henkin_enum d₀ (encodable.encode φ + 1) φ :=
begin
  intros h₁, classical, by_contra h₂,
  have ht : henkin_enum d₀ (encodable.encode φ + 1) (φ ↣ ⊥),
  {
    have ht' := henkin_enum_em d₀ φ,
    cases ht', exfalso, exact h₂ ht',
    exact ht'
  },
  have ht₁ := henkin_enum_subset d₀ h n (max n (encodable.encode φ + 1)) φ (le_max_left _ _) h₁,
  have ht₂ := henkin_enum_subset d₀ h _ (max n (encodable.encode φ + 1)) (φ↣⊥) (le_max_right _ _) ht,
  apply henkin_enum_consistent d₀ h (max n (encodable.encode φ + 1)) [φ, φ↣⊥],
  intros ψ,
  { intros a, simp at a, cases a, repeat {rewrite a, assumption} },
  {
    unfold conjunction,
    apply uncurry, existsi proof.ax2' _, prover
  }
end

lemma henkin_union_maximal {α agent : Type} [encodable (sentence α agent)]
  (d₀ : decider α agent) (h : consistent_set d₀) :
    ∀ φ, henkin_union d₀ φ ∨ henkin_union d₀ (φ ↣ ⊥) :=
begin
  intros φ,
  cases em (henkin_union d₀ φ) with h₁ h₁,
  { exact or.inl h₁ },
  {
    right, unfold henkin_union at *,
    have ht₂ : henkin_enum d₀ (encodable.encode φ + 1) (φ ↣ ⊥),
    {
      have ht₃ := henkin_enum_em d₀ φ,
      cases ht₃,
      { exfalso, exact h₁ ht₃ },
      { exact ht₃ }
    },
    apply henkin_enum_agree, repeat {assumption}
  }
end

lemma henkin_union_consistent_decider {α agent : Type} [encodable (sentence α agent)]
  (d₀ : decider α agent) (h : consistent_set d₀) :
    consistent_decider (henkin_union d₀) :=
begin
  unfold consistent_decider, split,
  { apply henkin_union_consistent, exact h },
  { apply henkin_union_maximal, exact h }
end

theorem dcomplete_extension {α agent : Type} [encodable (sentence α agent)] :
  ∀ d : decider α agent, consistent_set d →
    ∃ d' : decider_world α agent, (∀ φ, d φ → decides d' φ) :=
begin
  intros d₀ h,
  have ht := henkin_union_consistent_decider d₀ h,
  existsi (decider_world.mk (henkin_union d₀) ht),
  intros φ h₁, simp, apply henkin_union_subset, exact h, exact h₁
end

/-                ----4. Correctness of Henkin model----              -/

lemma decide_conjunction_know {α agent : Type} {s : decider_world α agent}
      {Γ : list _} {i : agent} :
  (∀ φ, φ ∈ Γ → decides s □(i:φ)) → decides s □(i : conjunction Γ) :=
begin
  intros h, induction Γ with φ Γ ih,
  { simp, apply decide_tauto, apply know_truth, apply id_provable },
  {
    cases Γ with ψ Γ,
    { unfold conjunction, apply h, simp },
    {
      unfold conjunction,
      have ht : decides s (□(i:φ)↣□(i:conjunction(ψ::Γ))↣□(i:φ&conjunction(ψ::Γ))),
      { apply decide_tauto, apply know_and_intro },
      apply decide_mp, apply decide_mp, exact ht,
      apply h, simp, apply ih, intros, apply h, simp [a]
    }
  }
end

lemma neighborhood {α agent : Type} [encodable (sentence α agent)]
  (s : decider_world α agent) (φ : sentence α agent) (i : agent) :
    decides s (□(i : φ)↣⊥) → (∃ t, (s ∼{i} t) ∧ decides t (φ↣⊥)) :=
begin
  intros a,
  have ht : ∃ t' : decider α agent, (∀ ψ, (ψ=φ↣⊥ ∨ decides s □(i:ψ)) ↔ t' ψ),
  { existsi (λ ψ, ψ = φ↣⊥ ∨ decides s □(i : ψ)), simp },
  cases ht with t' h₁,
  cases em (consistent_set t'),
  {
    cases dcomplete_extension t' h with t h₂,
    existsi t, split,
    {
      simp, intros ψ h₃, apply h₂,
      exact (h₁ ψ).mp (or.inr h₃)
    },
    { apply (h₂ (φ↣⊥)), apply (h₁ _).mp, left, refl }
  },
  {
    simp at h, cases h with Γ h₂,
    cases em (φ↣⊥ ∈ Γ),
    {
      cases (contra_imp_conseq h h₂.right) with Γ' h₃,
      have ht₁' : ⊢ conjunction Γ' ↣ φ,
      {
        apply hs_rule, exact h₃.right.right,
        existsi proof.ax3 _, prover
      },
      have ht₁ : decides s (□(i : conjunction Γ') ↣ □(i : φ)),
      {
        apply decide_tauto, cases ht₁',
        existsi proof.mp (proof.ax4 _ _ _) (proof.truth _), prover
      },
      have ht₂ : ∀ ψ, ψ ∈ Γ' → decides s □(i : ψ),
      {
        intros ψ h',
        cases (h₁ ψ).mpr (h₂.left ψ (h₃.left h')),
        { exfalso, apply h₃.right.left, rewrite ← h_1, exact h' },
        { exact h_1 }
      },
      have ht₃ := decide_conjunction_know ht₂,
      have ht₄ : decides s ⊥,
      {
        apply decide_mp, exact a,
        apply decide_mp, exact ht₁,
        exact ht₃
      },
      exfalso, cases s with s cons, apply cons.left [⊥],
      intros, simp at a_1, simp at ht₄, rewrite a_1, exact ht₄,
      simp, apply id_provable
    },
    {
      have ht₁ : ∀ ψ, ψ ∈ Γ → decides s □(i : ψ),
      {
        intros ψ h', cases (h₁ ψ).mpr (h₂.left _ h'),
        { exfalso, apply h, rewrite ← h_1, exact h' },
        { exact h_1 }
      },
      have ht₂ := decide_conjunction_know ht₁,
      have ht₃ : decides s ⊥,
      {
        apply decide_mp, apply decide_tauto, exact h₂.right,
        apply decide_mp, apply decide_tauto, existsi proof.ref _ _,
        apply proof_of.ref, exact i, exact ht₂,
      },
      exfalso, cases s with s cons, apply cons.left [⊥],
      intros, simp at a_1, simp at ht₃, rewrite a_1, exact ht₃,
      simp, apply id_provable
    }
  }
end

theorem henkin_correctness {α agent : Type} [encodable (sentence α agent)]:
  ∀ φ, static φ → ∀ s : decider_world α agent, (decides s φ ↔ ⦃s⦄ ⊨ φ) :=
begin
  intros φ st,
  induction φ with p φ₁ φ₂ ih₁ ih₂ i φ ih,
  { intro s, cases s with s h, simp },
  {
    intro s, cases s with s h, simp, intros a,
    apply h.left [⊥], simp, assumption,
    simp, apply id_provable
  },
  {
    intro s, cases st,
    unfold henkin_model at *, split,
    {
      intros a₁, unfold evaluate, intros a₂,
      classical, by_contra a₃,
      have h₁ := (ih₁ st_a s).mpr a₂,
      have h₂ := (decide_not_iff_not_decide _ _).mp
                   (not_imp_not.mpr (ih₂ st_a_1 s).mp a₃),
      have ht : decides s ⊥,
      { apply decide_mp, exact h₂, apply decide_mp, assumption, assumption },
      cases s with s h,
      apply h.left [⊥], simp at *, assumption,
      simp, apply id_provable
    },
    {
      intros a₁, unfold evaluate at *,
      cases (classical.em (decides s φ₁)),
      {
        classical, by_contra,
        have h' := (ih₂ st_a_1 s).mpr (a₁ ((ih₁ st_a s).mp h)),
        have h₂ := (decide_not_iff_not_decide _ _).mp a,
        have ht : decides s ⊥,
        { apply decide_mp, exact h₂, apply decide_useless_condition, assumption },
        cases s with s h₁,
        apply h₁.left [⊥], simp at *, assumption,
        simp, apply id_provable
      },
      {
        apply decide_false_condition,
        assumption
      }
    }
  },
  {
    intro s, cases st, split,
    {
      intros a₁ t a₂,
      apply (ih st_a_1 _).mp,
      simp at a₂, apply a₂, exact a₁
    },
    {
      intros a₁,
      have a₂ : ⦃s⦄ ⊨ φ, { apply a₁, apply access.reflexive, exact s },
      classical, by_contra,
      cases (neighborhood s φ i ((decide_not_iff_not_decide _ _).mp a)) with t h₁,
      apply (decide_not_iff_not_decide _ _).mpr h₁.right,
      apply (ih st_a_1 t).mpr,
      apply a₁, exact h₁.left
    }
  },
  { cases st }
end

end pal_logic


/-
Copyright (c) 2021 Yury G. Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury G. Kudryashov, Alex Kontorovich
-/
import order.filter.bases

/-!
# (Co)product of a family of filters

In this file we define two filters on `Π i, α i` and prove some basic properties of these filters.

* `filter.pi (f : Π i, filter (α i))` to be the maximal filter on `Π i, α i` such that
  `∀ i, filter.tendsto (function.eval i) (filter.pi f) (f i)`. It is defined as
  `Π i, filter.comap (function.eval i) (f i)`. This is a generalization of `filter.prod` to indexed
  products.

* `filter.Coprod (f : Π i, filter (α i))`: a generalization of `filter.coprod`; it is the supremum
  of `comap (eval i) (f i)`.
-/

open set function
open_locale classical filter

namespace filter

variables {ι : Type*} {α : ι → Type*} {f f₁ f₂ : Π i, filter (α i)} {s : Π i, set (α i)}

section pi

/-- The product of an indexed family of filters. -/
def pi (f : Π i, filter (α i)) : filter (Π i, α i) := ⨅ i, comap (eval i) (f i)

lemma tendsto_eval_pi (f : Π i, filter (α i)) (i : ι) :
  tendsto (eval i) (pi f) (f i) :=
tendsto_infi' i tendsto_comap

lemma tendsto_pi {β : Type*} {m : β → Π i, α i} {l : filter β} :
  tendsto m l (pi f) ↔ ∀ i, tendsto (λ x, m x i) l (f i) :=
by simp only [pi, tendsto_infi, tendsto_comap_iff]

lemma le_pi {g : filter (Π i, α i)} : g ≤ pi f ↔ ∀ i, tendsto (eval i) g (f i) := tendsto_pi

@[mono] lemma pi_mono (h : ∀ i, f₁ i ≤ f₂ i) : pi f₁ ≤ pi f₂ := infi_mono $ λ i, comap_mono $ h i

lemma mem_pi_of_mem (i : ι) {s : set (α i)} (hs : s ∈ f i) :
  eval i ⁻¹' s ∈ pi f :=
mem_infi_of_mem i $ preimage_mem_comap hs

lemma pi_mem_pi {I : set ι} (hI : I.finite) (h : ∀ i ∈ I, s i ∈ f i) :
  I.pi s ∈ pi f :=
begin
  rw [pi_def, bInter_eq_Inter],
  refine mem_infi_of_Inter hI (λ i, _) subset.rfl,
  exact preimage_mem_comap (h i i.2)
end

lemma mem_pi {s : set (Π i, α i)} : s ∈ pi f ↔
  ∃ (I : set ι), I.finite ∧ ∃ t : Π i, set (α i), (∀ i, t i ∈ f i) ∧ I.pi t ⊆ s :=
begin
  split,
  { simp only [pi, mem_infi', mem_comap, pi_def],
    rintro ⟨I, If, V, hVf, hVI, rfl, -⟩, choose t htf htV using hVf,
    exact ⟨I, If, t, htf, Inter₂_mono (λ i _, htV i)⟩ },
  { rintro ⟨I, If, t, htf, hts⟩,
    exact mem_of_superset (pi_mem_pi If $ λ i _, htf i) hts }
end

lemma mem_pi' {s : set (Π i, α i)} : s ∈ pi f ↔
  ∃ (I : finset ι), ∃ t : Π i, set (α i), (∀ i, t i ∈ f i) ∧ set.pi ↑I t ⊆ s :=
mem_pi.trans exists_finite_iff_finset

lemma mem_of_pi_mem_pi [∀ i, ne_bot (f i)] {I : set ι} (h : I.pi s ∈ pi f) {i : ι} (hi : i ∈ I) :
  s i ∈ f i :=
begin
  rcases mem_pi.1 h with ⟨I', I'f, t, htf, hts⟩,
  refine mem_of_superset (htf i) (λ x hx, _),
  have : ∀ i, (t i).nonempty, from λ i, nonempty_of_mem (htf i),
  choose g hg,
  have : update g i x ∈ I'.pi t,
  { intros j hj, rcases eq_or_ne j i with (rfl|hne); simp * },
  simpa using hts this i hi
end

@[simp] lemma pi_mem_pi_iff [∀ i, ne_bot (f i)] {I : set ι} (hI : I.finite) :
  I.pi s ∈ pi f ↔ ∀ i ∈ I, s i ∈ f i :=
⟨λ h i hi, mem_of_pi_mem_pi h hi, pi_mem_pi hI⟩

lemma has_basis_pi {ι' : ι → Type} {s : Π i, ι' i → set (α i)} {p : Π i, ι' i → Prop}
  (h : ∀ i, (f i).has_basis (p i) (s i)) :
  (pi f).has_basis (λ If : set ι × Π i, ι' i, If.1.finite ∧ ∀ i ∈ If.1, p i (If.2 i))
    (λ If : set ι × Π i, ι' i, If.1.pi (λ i, s i $ If.2 i)) :=
begin
  have : (pi f).has_basis _ _ := has_basis_infi (λ i, (h i).comap (eval i : (Π j, α j) → α i)),
  convert this,
  ext,
  simp
end

@[simp] lemma pi_inf_principal_univ_pi_eq_bot :
  pi f ⊓ 𝓟 (set.pi univ s) = ⊥ ↔ ∃ i, f i ⊓ 𝓟 (s i) = ⊥ :=
begin
  split,
  { simp only [inf_principal_eq_bot, mem_pi], contrapose!,
    rintros (hsf : ∀ i, ∃ᶠ x in f i, x ∈ s i) I If t htf hts,
    have : ∀ i, (s i ∩ t i).nonempty, from λ i, ((hsf i).and_eventually (htf i)).exists,
    choose x hxs hxt,
    exact hts (λ i hi, hxt i) (mem_univ_pi.2 hxs) },
  { simp only [inf_principal_eq_bot],
    rintro ⟨i, hi⟩,
    filter_upwards [mem_pi_of_mem i hi] with x using mt (λ h, h i trivial), },
end

@[simp] lemma pi_inf_principal_pi_eq_bot [Π i, ne_bot (f i)] {I : set ι} :
  pi f ⊓ 𝓟 (set.pi I s) = ⊥ ↔ ∃ i ∈ I, f i ⊓ 𝓟 (s i) = ⊥ :=
begin
  rw [← univ_pi_piecewise I, pi_inf_principal_univ_pi_eq_bot],
  refine exists_congr (λ i, _),
  by_cases hi : i ∈ I; simp [hi, (‹Π i, ne_bot (f i)› i).ne]
end

@[simp] lemma pi_inf_principal_univ_pi_ne_bot :
  ne_bot (pi f ⊓ 𝓟 (set.pi univ s)) ↔ ∀ i, ne_bot (f i ⊓ 𝓟 (s i)) :=
by simp [ne_bot_iff]

@[simp] lemma pi_inf_principal_pi_ne_bot [Π i, ne_bot (f i)] {I : set ι} :
  ne_bot (pi f ⊓ 𝓟 (I.pi s)) ↔ ∀ i ∈ I, ne_bot (f i ⊓ 𝓟 (s i)) :=
by simp [ne_bot_iff]

instance pi_inf_principal_pi.ne_bot [h : ∀ i, ne_bot (f i ⊓ 𝓟 (s i))] {I : set ι} :
  ne_bot (pi f ⊓ 𝓟 (I.pi s)) :=
(pi_inf_principal_univ_pi_ne_bot.2 ‹_›).mono $ inf_le_inf_left _ $ principal_mono.2 $
  λ x hx i hi, hx i trivial

@[simp] lemma pi_eq_bot : pi f = ⊥ ↔ ∃ i, f i = ⊥ :=
by simpa using @pi_inf_principal_univ_pi_eq_bot ι α f (λ _, univ)

@[simp]

instance [∀ i, ne_bot (f i)] : ne_bot (pi f) := pi_ne_bot.2 ‹_›

end pi

/-! ### `n`-ary coproducts of filters -/

section Coprod

/-- Coproduct of filters. -/
protected def Coprod (f : Π i, filter (α i)) : filter (Π i, α i) :=
⨆ i : ι, comap (eval i) (f i)

lemma mem_Coprod_iff {s : set (Π i, α i)} :
  (s ∈ filter.Coprod f) ↔ (∀ i : ι, (∃ t₁ ∈ f i, eval i ⁻¹' t₁ ⊆ s)) :=
by simp [filter.Coprod]

lemma compl_mem_Coprod {s : set (Π i, α i)} :
  sᶜ ∈ filter.Coprod f ↔ ∀ i, (eval i '' s)ᶜ ∈ f i :=
by simp only [filter.Coprod, mem_supr, compl_mem_comap]

lemma Coprod_ne_bot_iff' :
  ne_bot (filter.Coprod f) ↔ (∀ i, nonempty (α i)) ∧ ∃ d, ne_bot (f d) :=
by simp only [filter.Coprod, supr_ne_bot, ← exists_and_distrib_left, ← comap_eval_ne_bot_iff']

@[simp] lemma Coprod_ne_bot_iff [∀ i, nonempty (α i)] :
  ne_bot (filter.Coprod f) ↔ ∃ d, ne_bot (f d) :=
by simp [Coprod_ne_bot_iff', *]

lemma Coprod_eq_bot_iff' : filter.Coprod f = ⊥ ↔ (∃ i, is_empty (α i)) ∨ f = ⊥ :=
by simpa [not_and_distrib, funext_iff] using not_congr Coprod_ne_bot_iff'

@[simp] lemma Coprod_eq_bot_iff [∀ i, nonempty (α i)] : filter.Coprod f = ⊥ ↔ f = ⊥ :=
by simpa [funext_iff] using not_congr Coprod_ne_bot_iff

@[simp] lemma Coprod_bot' : filter.Coprod (⊥ : Π i, filter (α i)) = ⊥ :=
Coprod_eq_bot_iff'.2 (or.inr rfl)

@[simp] lemma Coprod_bot : filter.Coprod (λ _, ⊥ : Π i, filter (α i)) = ⊥ := Coprod_bot'

lemma ne_bot.Coprod [∀ i, nonempty (α i)] {i : ι} (h : ne_bot (f i)) :
  ne_bot (filter.Coprod f) :=
Coprod_ne_bot_iff.2 ⟨i, h⟩

@[instance] lemma Coprod_ne_bot [∀ i, nonempty (α i)] [nonempty ι] (f : Π i, filter (α i))
  [H : ∀ i, ne_bot (f i)] : ne_bot (filter.Coprod f) :=
(H (classical.arbitrary ι)).Coprod

@[mono] lemma Coprod_mono (hf : ∀ i, f₁ i ≤ f₂ i) : filter.Coprod f₁ ≤ filter.Coprod f₂ :=
supr_mono $ λ i, comap_mono (hf i)

variables {β : ι → Type*} {m : Π i, α i → β i}

lemma map_pi_map_Coprod_le :
  map (λ (k : Π i, α i), λ i, m i (k i)) (filter.Coprod f) ≤ filter.Coprod (λ i, map (m i) (f i)) :=
begin
  simp only [le_def, mem_map, mem_Coprod_iff],
  intros s h i,
  obtain ⟨t, H, hH⟩ := h i,
  exact ⟨{x : α i | m i x ∈ t}, H, λ x hx, hH hx⟩
end

lemma tendsto.pi_map_Coprod {g : Π i, filter (β i)} (h : ∀ i, tendsto (m i) (f i) (g i)) :
  tendsto (λ (k : Π i, α i), λ i, m i (k i)) (filter.Coprod f) (filter.Coprod g) :=
map_pi_map_Coprod_le.trans (Coprod_mono h)

end Coprod

end filter


/-
Copyright (c) 2021 Anatole Dedecker. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anatole Dedecker
-/
import analysis.normed_space.exponential
import analysis.calculus.fderiv_analytic
import data.complex.exponential
import topology.metric_space.cau_seq_filter

/-!
# Calculus results on exponential in a Banach algebra

In this file, we prove basic properties about the derivative of the exponential map `exp 𝕂`
in a Banach algebra `𝔸` over a field `𝕂`. We keep them separate from the main file
`analysis/normed_space/exponential` in order to minimize dependencies.

## Main results

We prove most result for an arbitrary field `𝕂`, and then specialize to `𝕂 = ℝ` or `𝕂 = ℂ`.

### General case

- `has_strict_fderiv_at_exp_zero_of_radius_pos` : `exp 𝕂` has strict Fréchet-derivative
  `1 : 𝔸 →L[𝕂] 𝔸` at zero, as long as it converges on a neighborhood of zero
  (see also `has_strict_deriv_at_exp_zero_of_radius_pos` for the case `𝔸 = 𝕂`)
- `has_strict_fderiv_at_exp_of_lt_radius` : if `𝕂` has characteristic zero and `𝔸` is commutative,
  then given a point `x` in the disk of convergence, `exp 𝕂` as strict Fréchet-derivative
  `exp 𝕂 x • 1 : 𝔸 →L[𝕂] 𝔸` at x (see also `has_strict_deriv_at_exp_of_lt_radius` for the case
  `𝔸 = 𝕂`)

### `𝕂 = ℝ` or `𝕂 = ℂ`

- `has_strict_fderiv_at_exp_zero` : `exp 𝕂` has strict Fréchet-derivative `1 : 𝔸 →L[𝕂] 𝔸` at zero
  (see also `has_strict_deriv_at_exp_zero` for the case `𝔸 = 𝕂`)
- `has_strict_fderiv_at_exp` : if `𝔸` is commutative, then given any point `x`, `exp 𝕂` as strict
  Fréchet-derivative `exp 𝕂 x • 1 : 𝔸 →L[𝕂] 𝔸` at x (see also `has_strict_deriv_at_exp` for the
  case `𝔸 = 𝕂`)

### Compatibilty with `real.exp` and `complex.exp`

- `complex.exp_eq_exp_ℂ` : `complex.exp = exp ℂ ℂ`
- `real.exp_eq_exp_ℝ` : `real.exp = exp ℝ ℝ`

-/

open filter is_R_or_C continuous_multilinear_map normed_field asymptotics
open_locale nat topology big_operators ennreal

section any_field_any_algebra

variables {𝕂 𝔸 : Type*} [nontrivially_normed_field 𝕂] [normed_ring 𝔸] [normed_algebra 𝕂 𝔸]
  [complete_space 𝔸]

/-- The exponential in a Banach-algebra `𝔸` over a normed field `𝕂` has strict Fréchet-derivative
`1 : 𝔸 →L[𝕂] 𝔸` at zero, as long as it converges on a neighborhood of zero. -/
lemma has_strict_fderiv_at_exp_zero_of_radius_pos (h : 0 < (exp_series 𝕂 𝔸).radius) :
  has_strict_fderiv_at (exp 𝕂) (1 : 𝔸 →L[𝕂] 𝔸) 0 :=
begin
  convert (has_fpower_series_at_exp_zero_of_radius_pos h).has_strict_fderiv_at,
  ext x,
  change x = exp_series 𝕂 𝔸 1 (λ _, x),
  simp [exp_series_apply_eq]
end

/-- The exponential in a Banach-algebra `𝔸` over a normed field `𝕂` has Fréchet-derivative
`1 : 𝔸 →L[𝕂] 𝔸` at zero, as long as it converges on a neighborhood of zero. -/
lemma has_fderiv_at_exp_zero_of_radius_pos (h : 0 < (exp_series 𝕂 𝔸).radius) :
  has_fderiv_at (exp 𝕂) (1 : 𝔸 →L[𝕂] 𝔸) 0 :=
(has_strict_fderiv_at_exp_zero_of_radius_pos h).has_fderiv_at

end any_field_any_algebra

section any_field_comm_algebra

variables {𝕂 𝔸 : Type*} [nontrivially_normed_field 𝕂] [normed_comm_ring 𝔸] [normed_algebra 𝕂 𝔸]
  [complete_space 𝔸]

/-- The exponential map in a commutative Banach-algebra `𝔸` over a normed field `𝕂` of
characteristic zero has Fréchet-derivative `exp 𝕂 x • 1 : 𝔸 →L[𝕂] 𝔸` at any point `x` in the
disk of convergence. -/
lemma has_fderiv_at_exp_of_mem_ball [char_zero 𝕂] {x : 𝔸}
  (hx : x ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius) :
  has_fderiv_at (exp 𝕂) (exp 𝕂 x • 1 : 𝔸 →L[𝕂] 𝔸) x :=
begin
  have hpos : 0 < (exp_series 𝕂 𝔸).radius := (zero_le _).trans_lt hx,
  rw has_fderiv_at_iff_is_o_nhds_zero,
  suffices : (λ h, exp 𝕂 x * (exp 𝕂 (0 + h) - exp 𝕂 0 - continuous_linear_map.id 𝕂 𝔸 h))
    =ᶠ[𝓝 0] (λ h, exp 𝕂 (x + h) - exp 𝕂 x - exp 𝕂 x • continuous_linear_map.id 𝕂 𝔸 h),
  { refine (is_o.const_mul_left _ _).congr' this (eventually_eq.refl _ _),
    rw ← has_fderiv_at_iff_is_o_nhds_zero,
    exact has_fderiv_at_exp_zero_of_radius_pos hpos },
  have : ∀ᶠ h in 𝓝 (0 : 𝔸), h ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius :=
    emetric.ball_mem_nhds _ hpos,
  filter_upwards [this] with _ hh,
  rw [exp_add_of_mem_ball hx hh, exp_zero, zero_add, continuous_linear_map.id_apply, smul_eq_mul],
  ring
end

/-- The exponential map in a commutative Banach-algebra `𝔸` over a normed field `𝕂` of
characteristic zero has strict Fréchet-derivative `exp 𝕂 x • 1 : 𝔸 →L[𝕂] 𝔸` at any point `x` in
the disk of convergence. -/
lemma has_strict_fderiv_at_exp_of_mem_ball [char_zero 𝕂] {x : 𝔸}
  (hx : x ∈ emetric.ball (0 : 𝔸) (exp_series 𝕂 𝔸).radius) :
  has_strict_fderiv_at (exp 𝕂) (exp 𝕂 x • 1 : 𝔸 →L[𝕂] 𝔸) x :=
let ⟨p, hp⟩ := analytic_at_exp_of_mem_ball x hx in
hp.has_fderiv_at.unique (has_fderiv_at_exp_of_mem_ball hx) ▸ hp.has_strict_fderiv_at

end any_field_comm_algebra

section deriv

variables {𝕂 : Type*} [nontrivially_normed_field 𝕂] [complete_space 𝕂]

/-- The exponential map in a complete normed field `𝕂` of characteristic zero has strict derivative
`exp 𝕂 x` at any point `x` in the disk of convergence. -/
lemma has_strict_deriv_at_exp_of_mem_ball [char_zero 𝕂] {x : 𝕂}
  (hx : x ∈ emetric.ball (0 : 𝕂) (exp_series 𝕂 𝕂).radius) :
  has_strict_deriv_at (exp 𝕂) (exp 𝕂 x) x :=
by simpa using (has_strict_fderiv_at_exp_of_mem_ball hx).has_strict_deriv_at

/-- The exponential map in a complete normed field `𝕂` of characteristic zero has derivative
`exp 𝕂 x` at any point `x` in the disk of convergence. -/
lemma has_deriv_at_exp_of_mem_ball [char_zero 𝕂] {x : 𝕂}
  (hx : x ∈ emetric.ball (0 : 𝕂) (exp_series 𝕂 𝕂).radius) :
  has_deriv_at (exp 𝕂) (exp 𝕂 x) x :=
(has_strict_deriv_at_exp_of_mem_ball hx).has_deriv_at

/-- The exponential map in a complete normed field `𝕂` of characteristic zero has strict derivative
`1` at zero, as long as it converges on a neighborhood of zero. -/
lemma has_strict_deriv_at_exp_zero_of_radius_pos (h : 0 < (exp_series 𝕂 𝕂).radius) :
  has_strict_deriv_at (exp 𝕂) (1 : 𝕂) 0 :=
(has_strict_fderiv_at_exp_zero_of_radius_pos h).has_strict_deriv_at

/-- The exponential map in a complete normed field `𝕂` of characteristic zero has derivative
`1` at zero, as long as it converges on a neighborhood of zero. -/
lemma has_deriv_at_exp_zero_of_radius_pos (h : 0 < (exp_series 𝕂 𝕂).radius) :
  has_deriv_at (exp 𝕂) (1 : 𝕂) 0 :=
(has_strict_deriv_at_exp_zero_of_radius_pos h).has_deriv_at

end deriv

section is_R_or_C_any_algebra

variables {𝕂 𝔸 : Type*} [is_R_or_C 𝕂] [normed_ring 𝔸] [normed_algebra 𝕂 𝔸]
  [complete_space 𝔸]

/-- The exponential in a Banach-algebra `𝔸` over `𝕂 = ℝ` or `𝕂 = ℂ` has strict Fréchet-derivative
`1 : 𝔸 →L[𝕂] 𝔸` at zero. -/
lemma has_strict_fderiv_at_exp_zero :
  has_strict_fderiv_at (exp 𝕂) (1 : 𝔸 →L[𝕂] 𝔸) 0 :=
has_strict_fderiv_at_exp_zero_of_radius_pos (exp_series_radius_pos 𝕂 𝔸)

/-- The exponential in a Banach-algebra `𝔸` over `𝕂 = ℝ` or `𝕂 = ℂ` has Fréchet-derivative
`1 : 𝔸 →L[𝕂] 𝔸` at zero. -/
lemma has_fderiv_at_exp_zero :
  has_fderiv_at (exp 𝕂) (1 : 𝔸 →L[𝕂] 𝔸) 0 :=
has_strict_fderiv_at_exp_zero.has_fderiv_at

end is_R_or_C_any_algebra

section is_R_or_C_comm_algebra

variables {𝕂 𝔸 : Type*} [is_R_or_C 𝕂] [normed_comm_ring 𝔸] [normed_algebra 𝕂 𝔸]
  [complete_space 𝔸]

/-- The exponential map in a commutative Banach-algebra `𝔸` over `𝕂 = ℝ` or `𝕂 = ℂ` has strict
Fréchet-derivative `exp 𝕂 x • 1 : 𝔸 →L[𝕂] 𝔸` at any point `x`. -/
lemma has_strict_fderiv_at_exp {x : 𝔸} :
  has_strict_fderiv_at (exp 𝕂) (exp 𝕂 x • 1 : 𝔸 →L[𝕂] 𝔸) x :=
has_strict_fderiv_at_exp_of_mem_ball ((exp_series_radius_eq_top 𝕂 𝔸).symm ▸ edist_lt_top _ _)

/-- The exponential map in a commutative Banach-algebra `𝔸` over `𝕂 = ℝ` or `𝕂 = ℂ` has
Fréchet-derivative `exp 𝕂 x • 1 : 𝔸 →L[𝕂] 𝔸` at any point `x`. -/
lemma has_fderiv_at_exp {x : 𝔸} :
  has_fderiv_at (exp 𝕂) (exp 𝕂 x • 1 : 𝔸 →L[𝕂] 𝔸) x :=
has_strict_fderiv_at_exp.has_fderiv_at

end is_R_or_C_comm_algebra

section deriv_R_or_C

variables {𝕂 : Type*} [is_R_or_C 𝕂]

/-- The exponential map in `𝕂 = ℝ` or `𝕂 = ℂ` has strict derivative `exp 𝕂 x` at any point
`x`. -/
lemma has_strict_deriv_at_exp {x : 𝕂} : has_strict_deriv_at (exp 𝕂) (exp 𝕂 x) x :=
has_strict_deriv_at_exp_of_mem_ball ((exp_series_radius_eq_top 𝕂 𝕂).symm ▸ edist_lt_top _ _)

/-- The exponential map in `𝕂 = ℝ` or `𝕂 = ℂ` has derivative `exp 𝕂 x` at any point `x`. -/
lemma has_deriv_at_exp {x : 𝕂} : has_deriv_at (exp 𝕂) (exp 𝕂 x) x :=
has_strict_deriv_at_exp.has_deriv_at

/-- The exponential map in `𝕂 = ℝ` or `𝕂 = ℂ` has strict derivative `1` at zero. -/
lemma has_strict_deriv_at_exp_zero : has_strict_deriv_at (exp 𝕂) (1 : 𝕂) 0 :=
has_strict_deriv_at_exp_zero_of_radius_pos (exp_series_radius_pos 𝕂 𝕂)

/-- The exponential map in `𝕂 = ℝ` or `𝕂 = ℂ` has derivative `1` at zero. -/
lemma has_deriv_at_exp_zero :
  has_deriv_at (exp 𝕂) (1 : 𝕂) 0 :=
has_strict_deriv_at_exp_zero.has_deriv_at

end deriv_R_or_C

lemma complex.exp_eq_exp_ℂ : complex.exp = exp ℂ :=
begin
  refine funext (λ x, _),
  rw [complex.exp, exp_eq_tsum_div],
  exact tendsto_nhds_unique x.exp'.tendsto_limit
    (exp_series_div_summable ℝ x).has_sum.tendsto_sum_nat
end

lemma real.exp_eq_exp_ℝ : real.exp = exp ℝ :=
by { ext x, exact_mod_cast congr_fun complex.exp_eq_exp_ℂ x }


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

import data.set.finite
import group_theory.perm.sign
import logic.equiv.basic

/-! # Equivalence between fintypes

This file contains some basic results on equivalences where one or both
sides of the equivalence are `fintype`s.

# Main definitions

 - `function.embedding.to_equiv_range`: computably turn an embedding of a
   fintype into an `equiv` of the domain to its range
 - `equiv.perm.via_fintype_embedding : perm α → (α ↪ β) → perm β` extends the domain of
   a permutation, fixing everything outside the range of the embedding

# Implementation details

 - `function.embedding.to_equiv_range` uses a computable inverse, but one that has poor
   computational performance, since it operates by exhaustive search over the input `fintype`s.
-/

variables {α β : Type*} [fintype α] [decidable_eq β] (e : equiv.perm α) (f : α ↪ β)

/--
Computably turn an embedding `f : α ↪ β` into an equiv `α ≃ set.range f`,
if `α` is a `fintype`. Has poor computational performance, due to exhaustive searching in
constructed inverse. When a better inverse is known, use `equiv.of_left_inverse'` or
`equiv.of_left_inverse` instead. This is the computable version of `equiv.of_injective`.
-/
def function.embedding.to_equiv_range : α ≃ set.range f :=
⟨λ a, ⟨f a, set.mem_range_self a⟩, f.inv_of_mem_range, λ _, by simp, λ _, by simp⟩

@[simp] lemma function.embedding.to_equiv_range_apply (a : α) :
  f.to_equiv_range a = ⟨f a, set.mem_range_self a⟩ := rfl

@[simp] lemma function.embedding.to_equiv_range_symm_apply_self (a : α) :
  f.to_equiv_range.symm ⟨f a, set.mem_range_self a⟩ = a :=
by simp [equiv.symm_apply_eq]

lemma function.embedding.to_equiv_range_eq_of_injective :
  f.to_equiv_range = equiv.of_injective f f.injective :=
by { ext, simp }

/--
Extend the domain of `e : equiv.perm α`, mapping it through `f : α ↪ β`.
Everything outside of `set.range f` is kept fixed. Has poor computational performance,
due to exhaustive searching in constructed inverse due to using `function.embedding.to_equiv_range`.
When a better `α ≃ set.range f` is known, use `equiv.perm.via_set_range`.
When `[fintype α]` is not available, a noncomputable version is available as
`equiv.perm.via_embedding`.
-/
def equiv.perm.via_fintype_embedding : equiv.perm β :=
e.extend_domain f.to_equiv_range

@[simp] lemma equiv.perm.via_fintype_embedding_apply_image (a : α) :
  e.via_fintype_embedding f (f a) = f (e a) :=
begin
  rw equiv.perm.via_fintype_embedding,
  convert equiv.perm.extend_domain_apply_image e _ _
end

lemma equiv.perm.via_fintype_embedding_apply_mem_range {b : β} (h : b ∈ set.range f) :
  e.via_fintype_embedding f b = f (e (f.inv_of_mem_range ⟨b, h⟩)) :=
by simpa [equiv.perm.via_fintype_embedding, equiv.perm.extend_domain_apply_subtype, h]

lemma equiv.perm.via_fintype_embedding_apply_not_mem_range {b : β} (h : b ∉ set.range f) :
  e.via_fintype_embedding f b = b :=
by rwa [equiv.perm.via_fintype_embedding, equiv.perm.extend_domain_apply_not_subtype]

@[simp] lemma equiv.perm.via_fintype_embedding_sign [decidable_eq α] [fintype β] :
  equiv.perm.sign (e.via_fintype_embedding f) = equiv.perm.sign e :=
by simp [equiv.perm.via_fintype_embedding]

namespace equiv
variables {p q : α → Prop} [decidable_pred p] [decidable_pred q]

/-- If `e` is an equivalence between two subtypes of a fintype `α`, `e.to_compl`
is an equivalence between the complement of those subtypes.

See also `equiv.compl`, for a computable version when a term of type
`{e' : α ≃ α // ∀ x : {x // p x}, e' x = e x}` is known. -/
noncomputable def to_compl (e : {x // p x} ≃ {x // q x}) : {x // ¬ p x} ≃ {x // ¬ q x} :=
classical.choice (fintype.card_eq.mp (fintype.card_compl_eq_card_compl (fintype.card_congr e)))

/-- If `e` is an equivalence between two subtypes of a fintype `α`, `e.extend_subtype`
is a permutation of `α` acting like `e` on the subtypes and doing something arbitrary outside.

Note that when `p = q`, `equiv.perm.subtype_congr e (equiv.refl _)` can be used instead. -/
noncomputable abbreviation extend_subtype (e : {x // p x} ≃ {x // q x}) : perm α :=
subtype_congr e e.to_compl

lemma extend_subtype_apply_of_mem (e : {x // p x} ≃ {x // q x}) (x) (hx : p x) :
  e.extend_subtype x = e ⟨x, hx⟩ :=
by { dunfold extend_subtype,
     simp only [subtype_congr, equiv.trans_apply, equiv.sum_congr_apply],
     rw [sum_compl_apply_symm_of_pos _ _ hx, sum.map_inl, sum_compl_apply_inl] }

lemma extend_subtype_mem (e : {x // p x} ≃ {x // q x}) (x) (hx : p x) :
  q (e.extend_subtype x) :=
by { convert (e ⟨x, hx⟩).2,
     rw [e.extend_subtype_apply_of_mem _ hx, subtype.val_eq_coe] }

lemma extend_subtype_not_mem (e : {x // p x} ≃ {x // q x}) (x) (hx : ¬ p x) :
  ¬ q (e.extend_subtype x) :=
by { convert (e.to_compl ⟨x, hx⟩).2,
     rw [e.extend_subtype_apply_of_not_mem _ hx, subtype.val_eq_coe] }

end equiv