/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sebastian Ullrich
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.control.monad
import Mathlib.Lean3Lib.init.meta.interactive
import Mathlib.Lean3Lib.init.control.state
import Mathlib.Lean3Lib.init.control.except
import Mathlib.Lean3Lib.init.control.reader
import Mathlib.Lean3Lib.init.control.option

universes u v l u_1

namespace Mathlib

class is_lawful_functor (f : Type u → Type v) [Functor f] where
  map_const_eq :
    autoParam (∀ {α β : Type u}, Functor.mapConst = Functor.map ∘ function.const β)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.control_laws_tac")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "control_laws_tac") [])
  id_map : ∀ {α : Type u} (x : f α), id <$> x = x
  comp_map : ∀ {α β γ : Type u} (g : α → β) (h : β → γ) (x : f α), (h ∘ g) <$> x = h <$> g <$> x

-- `functor` is indeed a categorical functor

-- `comp_map` does not make a good simp lemma

class is_lawful_applicative (f : Type u → Type v) [Applicative f] extends is_lawful_functor f where
  seq_left_eq :
    autoParam (∀ {α β : Type u} (a : f α) (b : f β), a <* b = function.const β <$> a <*> b)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.control_laws_tac")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "control_laws_tac") [])
  seq_right_eq :
    autoParam (∀ {α β : Type u} (a : f α) (b : f β), a *> b = function.const α id <$> a <*> b)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.control_laws_tac")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "control_laws_tac") [])
  pure_seq_eq_map : ∀ {α β : Type u} (g : α → β) (x : f α), pure g <*> x = g <$> x
  map_pure : ∀ {α β : Type u} (g : α → β) (x : α), g <$> pure x = pure (g x)
  seq_pure : ∀ {α β : Type u} (g : f (α → β)) (x : α), g <*> pure x = (fun (g : α → β) => g x) <$> g
  seq_assoc :
    ∀ {α β γ : Type u} (x : f α) (g : f (α → β)) (h : f (β → γ)),
      h <*> (g <*> x) = function.comp <$> h <*> g <*> x

-- applicative laws

-- default functor law

-- applicative "law" derivable from other laws

@[simp] theorem pure_id_seq {α : Type u} {f : Type u → Type v} [Applicative f]
    [is_lawful_applicative f] (x : f α) : pure id <*> x = x :=
  sorry

class is_lawful_monad (m : Type u → Type v) [Monad m] extends is_lawful_applicative m where
  bind_pure_comp_eq_map :
    autoParam (∀ {α β : Type u} (f : α → β) (x : m α), x >>= pure ∘ f = f <$> x)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.control_laws_tac")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "control_laws_tac") [])
  bind_map_eq_seq :
    autoParam
      (∀ {α β : Type u} (f : m (α → β)) (x : m α),
        (do
            let _x ← f
            _x <$> x) =
          f <*> x)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.control_laws_tac")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "control_laws_tac") [])
  pure_bind : ∀ {α β : Type u} (x : α) (f : α → m β), pure x >>= f = f x
  bind_assoc :
    ∀ {α β γ : Type u} (x : m α) (f : α → m β) (g : β → m γ),
      x >>= f >>= g = x >>= fun (x : α) => f x >>= g

-- monad laws

-- monad "law" derivable from other laws

@[simp] theorem bind_pure {α : Type u} {m : Type u → Type v} [Monad m] [is_lawful_monad m]
    (x : m α) : x >>= pure = x :=
  sorry

theorem bind_ext_congr {α : Type u} {β : Type u} {m : Type u → Type v} [Bind m] {x : m α}
    {f : α → m β} {g : α → m β} : (∀ (a : α), f a = g a) → x >>= f = x >>= g :=
  sorry

theorem map_ext_congr {α : Type u} {β : Type u} {m : Type u → Type v} [Functor m] {x : m α}
    {f : α → β} {g : α → β} : (∀ (a : α), f a = g a) → f <$> x = g <$> x :=
  sorry

-- instances of previously defined monads

namespace id

@[simp] theorem map_eq {α : Type} {β : Type} (x : id α) (f : α → β) : f <$> x = f x := rfl

@[simp] theorem bind_eq {α : Type} {β : Type} (x : id α) (f : α → id β) : x >>= f = f x := rfl

end id

@[simp] theorem id.pure_eq {α : Type} (a : α) : pure a = a := rfl

protected instance id.is_lawful_monad : is_lawful_monad id :=
  is_lawful_monad.mk (fun (α β : Type u_1) (x : α) (f : α → id β) => Eq.refl (pure x >>= f))
    fun (α β γ : Type u_1) (x : id α) (f : α → id β) (g : β → id γ) => Eq.refl (x >>= f >>= g)

namespace state_t

theorem ext {σ : Type u} {m : Type u → Type v} {α : Type u} {x : state_t σ m α} {x' : state_t σ m α}
    (h : ∀ (st : σ), run x st = run x' st) : x = x' :=
  sorry

@[simp] theorem run_pure {σ : Type u} {m : Type u → Type v} {α : Type u} (st : σ) [Monad m]
    (a : α) : run (pure a) st = pure (a, st) :=
  rfl

@[simp] theorem run_bind {σ : Type u} {m : Type u → Type v} {α : Type u} {β : Type u}
    (x : state_t σ m α) (st : σ) [Monad m] (f : α → state_t σ m β) :
    run (x >>= f) st =
        do
          let p ← run x st
          run (f (prod.fst p)) (prod.snd p) :=
  sorry

@[simp] theorem run_map {σ : Type u} {m : Type u → Type v} {α : Type u} {β : Type u}
    (x : state_t σ m α) (st : σ) [Monad m] (f : α → β) [is_lawful_monad m] :
    run (f <$> x) st = (fun (p : α × σ) => (f (prod.fst p), prod.snd p)) <$> run x st :=
  sorry

@[simp] theorem run_monad_lift {σ : Type u} {m : Type u → Type v} {α : Type u} (st : σ) [Monad m]
    {n : Type u → Type u_1} [has_monad_lift_t n m] (x : n α) :
    run (monad_lift x) st =
        do
          let a ← monad_lift x
          pure (a, st) :=
  rfl

@[simp] theorem run_monad_map {σ : Type u} {m : Type u → Type v} {α : Type u} (x : state_t σ m α)
    (st : σ) [Monad m] {m' : Type u → Type v} {n : Type u → Type u_1} {n' : Type u → Type u_1}
    [Monad m'] [monad_functor_t n n' m m'] (f : {α : Type u} → n α → n' α) :
    run (monad_map f x) st = monad_map f (run x st) :=
  rfl

@[simp] theorem run_adapt {σ : Type u} {m : Type u → Type v} {α : Type u} [Monad m] {σ' : Type u}
    {σ'' : Type u} (st : σ) (split : σ → σ' × σ'') (join : σ' → σ'' → σ) (x : state_t σ' m α) :
    run (state_t.adapt split join x) st =
        (fun (_a : σ' × σ'') =>
            prod.cases_on _a
              fun (fst : σ') (snd : σ'') =>
                idRhs (m (α × σ))
                  (do
                    let _p ← run x fst
                    (fun (_a : α × σ') =>
                          prod.cases_on _a
                            fun (fst : α) (snd_1 : σ') =>
                              idRhs (m (α × σ)) (pure (fst, join snd_1 snd)))
                        _p))
          (split st) :=
  sorry

@[simp] theorem run_get {σ : Type u} {m : Type u → Type v} (st : σ) [Monad m] :
    run state_t.get st = pure (st, st) :=
  rfl

@[simp] theorem run_put {σ : Type u} {m : Type u → Type v} (st : σ) [Monad m] (st' : σ) :
    run (state_t.put st') st = pure (PUnit.unit, st') :=
  rfl

end state_t

protected instance state_t.is_lawful_monad (m : Type u → Type v) [Monad m] [is_lawful_monad m]
    (σ : Type u) : is_lawful_monad (state_t σ m) :=
  sorry

namespace except_t

theorem ext {α : Type u} {ε : Type u} {m : Type u → Type v} {x : except_t ε m α}
    {x' : except_t ε m α} (h : run x = run x') : x = x' :=
  sorry

@[simp] theorem run_pure {α : Type u} {ε : Type u} {m : Type u → Type v} [Monad m] (a : α) :
    run (pure a) = pure (except.ok a) :=
  rfl

@[simp] theorem run_bind {α : Type u} {β : Type u} {ε : Type u} {m : Type u → Type v}
    (x : except_t ε m α) [Monad m] (f : α → except_t ε m β) :
    run (x >>= f) = run x >>= except_t.bind_cont f :=
  rfl

@[simp] theorem run_map {α : Type u} {β : Type u} {ε : Type u} {m : Type u → Type v}
    (x : except_t ε m α) [Monad m] (f : α → β) [is_lawful_monad m] :
    run (f <$> x) = except.map f <$> run x :=
  sorry

@[simp] theorem run_monad_lift {α : Type u} {ε : Type u} {m : Type u → Type v} [Monad m]
    {n : Type u → Type u_1} [has_monad_lift_t n m] (x : n α) :
    run (monad_lift x) = except.ok <$> monad_lift x :=
  rfl

@[simp] theorem run_monad_map {α : Type u} {ε : Type u} {m : Type u → Type v} (x : except_t ε m α)
    [Monad m] {m' : Type u → Type v} {n : Type u → Type u_1} {n' : Type u → Type u_1} [Monad m']
    [monad_functor_t n n' m m'] (f : {α : Type u} → n α → n' α) :
    run (monad_map f x) = monad_map f (run x) :=
  rfl

end except_t

protected instance except_t.is_lawful_monad (m : Type u → Type v) [Monad m] [is_lawful_monad m]
    (ε : Type u) : is_lawful_monad (except_t ε m) :=
  sorry

namespace reader_t

theorem ext {ρ : Type u} {m : Type u → Type v} {α : Type u} {x : reader_t ρ m α}
    {x' : reader_t ρ m α} (h : ∀ (r : ρ), run x r = run x' r) : x = x' :=
  sorry

@[simp] theorem run_pure {ρ : Type u} {m : Type u → Type v} {α : Type u} (r : ρ) [Monad m] (a : α) :
    run (pure a) r = pure a :=
  rfl

@[simp] theorem run_bind {ρ : Type u} {m : Type u → Type v} {α : Type u} {β : Type u}
    (x : reader_t ρ m α) (r : ρ) [Monad m] (f : α → reader_t ρ m β) :
    run (x >>= f) r =
        do
          let a ← run x r
          run (f a) r :=
  rfl

@[simp] theorem run_map {ρ : Type u} {m : Type u → Type v} {α : Type u} {β : Type u}
    (x : reader_t ρ m α) (r : ρ) [Monad m] (f : α → β) [is_lawful_monad m] :
    run (f <$> x) r = f <$> run x r :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl (run (f <$> x) r = f <$> run x r))
        (Eq.symm (bind_pure_comp_eq_map f (run x r)))))
    (Eq.refl (run (f <$> x) r))

@[simp] theorem run_monad_lift {ρ : Type u} {m : Type u → Type v} {α : Type u} (r : ρ) [Monad m]
    {n : Type u → Type u_1} [has_monad_lift_t n m] (x : n α) :
    run (monad_lift x) r = monad_lift x :=
  rfl

@[simp] theorem run_monad_map {ρ : Type u} {m : Type u → Type v} {α : Type u} (x : reader_t ρ m α)
    (r : ρ) [Monad m] {m' : Type u → Type v} {n : Type u → Type u_1} {n' : Type u → Type u_1}
    [Monad m'] [monad_functor_t n n' m m'] (f : {α : Type u} → n α → n' α) :
    run (monad_map f x) r = monad_map f (run x r) :=
  rfl

@[simp] theorem run_read {ρ : Type u} {m : Type u → Type v} (r : ρ) [Monad m] :
    run reader_t.read r = pure r :=
  rfl

end reader_t

protected instance reader_t.is_lawful_monad (ρ : Type u) (m : Type u → Type v) [Monad m]
    [is_lawful_monad m] : is_lawful_monad (reader_t ρ m) :=
  sorry

namespace option_t

theorem ext {α : Type u} {m : Type u → Type v} {x : option_t m α} {x' : option_t m α}
    (h : run x = run x') : x = x' :=
  sorry

@[simp] theorem run_pure {α : Type u} {m : Type u → Type v} [Monad m] (a : α) :
    run (pure a) = pure (some a) :=
  rfl

@[simp] theorem run_bind {α : Type u} {β : Type u} {m : Type u → Type v} (x : option_t m α)
    [Monad m] (f : α → option_t m β) : run (x >>= f) = run x >>= option_t.bind_cont f :=
  rfl

@[simp] theorem run_map {α : Type u} {β : Type u} {m : Type u → Type v} (x : option_t m α) [Monad m]
    (f : α → β) [is_lawful_monad m] : run (f <$> x) = option.map f <$> run x :=
  sorry

@[simp] theorem run_monad_lift {α : Type u} {m : Type u → Type v} [Monad m] {n : Type u → Type u_1}
    [has_monad_lift_t n m] (x : n α) : run (monad_lift x) = some <$> monad_lift x :=
  rfl

@[simp] theorem run_monad_map {α : Type u} {m : Type u → Type v} (x : option_t m α) [Monad m]
    {m' : Type u → Type v} {n : Type u → Type u_1} {n' : Type u → Type u_1} [Monad m']
    [monad_functor_t n n' m m'] (f : {α : Type u} → n α → n' α) :
    run (monad_map f x) = monad_map f (run x) :=
  rfl

end option_t

protected instance option_t.is_lawful_monad (m : Type u → Type v) [Monad m] [is_lawful_monad m] :
    is_lawful_monad (option_t m) :=
  sorry

end Mathlib


/-
Copyright (c) 2014 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro

Natural homomorphism from the natural numbers into a monoid with one.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.ordered_field
import Mathlib.data.nat.basic
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

namespace nat

/-- Canonical homomorphism from `ℕ` to a type `α` with `0`, `1` and `+`. -/
protected def cast {α : Type u_1} [HasZero α] [HasOne α] [Add α] : ℕ → α :=
  sorry

/-- Computationally friendlier cast than `nat.cast`, using binary representation. -/
protected def bin_cast {α : Type u_1} [HasZero α] [HasOne α] [Add α] (n : ℕ) : α :=
  binary_rec 0 (fun (odd : Bool) (k : ℕ) (a : α) => cond odd (a + a + 1) (a + a)) n

/--
Coercions such as `nat.cast_coe` that go from a concrete structure such as
`ℕ` to an arbitrary ring `α` should be set up as follows:
```lean
@[priority 900] instance : has_coe_t ℕ α := ⟨...⟩
```

It needs to be `has_coe_t` instead of `has_coe` because otherwise type-class
inference would loop when constructing the transitive coercion `ℕ → ℕ → ℕ → ...`.
The reduced priority is necessary so that it doesn't conflict with instances
such as `has_coe_t α (option α)`.

For this to work, we reduce the priority of the `coe_base` and `coe_trans`
instances because we want the instances for `has_coe_t` to be tried in the
following order:

 1. `has_coe_t` instances declared in mathlib (such as `has_coe_t α (with_top α)`, etc.)
 2. `coe_base`, which contains instances such as `has_coe (fin n) n`
 3. `nat.cast_coe : has_coe_t ℕ α` etc.
 4. `coe_trans`

If `coe_trans` is tried first, then `nat.cast_coe` doesn't get a chance to apply.
-/
-- see note [coercion into rings]

protected instance cast_coe {α : Type u_1} [HasZero α] [HasOne α] [Add α] : has_coe_t ℕ α :=
  has_coe_t.mk nat.cast

@[simp] theorem cast_zero {α : Type u_1} [HasZero α] [HasOne α] [Add α] : ↑0 = 0 :=
  rfl

theorem cast_add_one {α : Type u_1} [HasZero α] [HasOne α] [Add α] (n : ℕ) : ↑(n + 1) = ↑n + 1 :=
  rfl

@[simp] theorem cast_succ {α : Type u_1} [HasZero α] [HasOne α] [Add α] (n : ℕ) : ↑(Nat.succ n) = ↑n + 1 :=
  rfl

@[simp] theorem cast_ite {α : Type u_1} [HasZero α] [HasOne α] [Add α] (P : Prop) [Decidable P] (m : ℕ) (n : ℕ) : ↑(ite P m n) = ite P ↑m ↑n := sorry

@[simp] theorem cast_one {α : Type u_1} [add_monoid α] [HasOne α] : ↑1 = 1 :=
  zero_add 1

@[simp] theorem cast_add {α : Type u_1} [add_monoid α] [HasOne α] (m : ℕ) (n : ℕ) : ↑(m + n) = ↑m + ↑n := sorry

@[simp] theorem bin_cast_eq {α : Type u_1} [add_monoid α] [HasOne α] (n : ℕ) : nat.bin_cast n = ↑n := sorry

/-- `coe : ℕ → α` as an `add_monoid_hom`. -/
def cast_add_monoid_hom (α : Type u_1) [add_monoid α] [HasOne α] : ℕ →+ α :=
  add_monoid_hom.mk coe sorry cast_add

@[simp] theorem coe_cast_add_monoid_hom {α : Type u_1} [add_monoid α] [HasOne α] : ⇑(cast_add_monoid_hom α) = coe :=
  rfl

@[simp] theorem cast_bit0 {α : Type u_1} [add_monoid α] [HasOne α] (n : ℕ) : ↑(bit0 n) = bit0 ↑n :=
  cast_add n n

@[simp] theorem cast_bit1 {α : Type u_1} [add_monoid α] [HasOne α] (n : ℕ) : ↑(bit1 n) = bit1 ↑n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑(bit1 n) = bit1 ↑n)) (bit1.equations._eqn_1 n)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑(bit0 n + 1) = bit1 ↑n)) (cast_add_one (bit0 n))))
      (eq.mpr (id (Eq._oldrec (Eq.refl (↑(bit0 n) + 1 = bit1 ↑n)) (cast_bit0 n))) (Eq.refl (bit0 ↑n + 1))))

theorem cast_two {α : Type u_1} [add_monoid α] [HasOne α] : ↑(bit0 1) = bit0 1 := sorry

@[simp] theorem cast_pred {α : Type u_1} [add_group α] [HasOne α] {n : ℕ} : 0 < n → ↑(n - 1) = ↑n - 1 := sorry

@[simp] theorem cast_sub {α : Type u_1} [add_group α] [HasOne α] {m : ℕ} {n : ℕ} (h : m ≤ n) : ↑(n - m) = ↑n - ↑m :=
  eq_sub_of_add_eq
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑(n - m) + ↑m = ↑n)) (Eq.symm (cast_add (n - m) m))))
      (eq.mpr (id (Eq._oldrec (Eq.refl (↑(n - m + m) = ↑n)) (nat.sub_add_cancel h))) (Eq.refl ↑n)))

@[simp] theorem cast_mul {α : Type u_1} [semiring α] (m : ℕ) (n : ℕ) : ↑(m * n) = ↑m * ↑n := sorry

@[simp] theorem cast_dvd {α : Type u_1} [field α] {m : ℕ} {n : ℕ} (n_dvd : n ∣ m) (n_nonzero : ↑n ≠ 0) : ↑(m / n) = ↑m / ↑n := sorry

/-- `coe : ℕ → α` as a `ring_hom` -/
def cast_ring_hom (α : Type u_1) [semiring α] : ℕ →+* α :=
  ring_hom.mk coe sorry cast_mul sorry sorry

@[simp] theorem coe_cast_ring_hom {α : Type u_1} [semiring α] : ⇑(cast_ring_hom α) = coe :=
  rfl

theorem cast_commute {α : Type u_1} [semiring α] (n : ℕ) (x : α) : commute (↑n) x :=
  nat.rec_on n (commute.zero_left x) fun (n : ℕ) (ihn : commute (↑n) x) => commute.add_left ihn (commute.one_left x)

theorem commute_cast {α : Type u_1} [semiring α] (x : α) (n : ℕ) : commute x ↑n :=
  commute.symm (cast_commute n x)

@[simp] theorem cast_nonneg {α : Type u_1} [ordered_semiring α] (n : ℕ) : 0 ≤ ↑n := sorry

theorem mono_cast {α : Type u_1} [ordered_semiring α] : monotone coe := sorry

theorem strict_mono_cast {α : Type u_1} [ordered_semiring α] [nontrivial α] : strict_mono coe :=
  fun (m n : ℕ) (h : m < n) =>
    le_induction (lt_add_of_pos_right (↑m) zero_lt_one)
      (fun (n : ℕ) (_x : Nat.succ m ≤ n) (h : ↑m < ↑n) => lt_add_of_lt_of_pos h zero_lt_one) n h

@[simp] theorem cast_le {α : Type u_1} [ordered_semiring α] [nontrivial α] {m : ℕ} {n : ℕ} : ↑m ≤ ↑n ↔ m ≤ n :=
  strict_mono.le_iff_le strict_mono_cast

@[simp] theorem cast_lt {α : Type u_1} [ordered_semiring α] [nontrivial α] {m : ℕ} {n : ℕ} : ↑m < ↑n ↔ m < n :=
  strict_mono.lt_iff_lt strict_mono_cast

@[simp] theorem cast_pos {α : Type u_1} [ordered_semiring α] [nontrivial α] {n : ℕ} : 0 < ↑n ↔ 0 < n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (0 < ↑n ↔ 0 < n)) (Eq.symm cast_zero)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑0 < ↑n ↔ 0 < n)) (propext cast_lt))) (iff.refl (0 < n)))

theorem cast_add_one_pos {α : Type u_1} [ordered_semiring α] [nontrivial α] (n : ℕ) : 0 < ↑n + 1 :=
  add_pos_of_nonneg_of_pos (cast_nonneg n) zero_lt_one

@[simp] theorem one_lt_cast {α : Type u_1} [ordered_semiring α] [nontrivial α] {n : ℕ} : 1 < ↑n ↔ 1 < n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (1 < ↑n ↔ 1 < n)) (Eq.symm cast_one)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑1 < ↑n ↔ 1 < n)) (propext cast_lt))) (iff.refl (1 < n)))

@[simp] theorem one_le_cast {α : Type u_1} [ordered_semiring α] [nontrivial α] {n : ℕ} : 1 ≤ ↑n ↔ 1 ≤ n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (1 ≤ ↑n ↔ 1 ≤ n)) (Eq.symm cast_one)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑1 ≤ ↑n ↔ 1 ≤ n)) (propext cast_le))) (iff.refl (1 ≤ n)))

@[simp] theorem cast_lt_one {α : Type u_1} [ordered_semiring α] [nontrivial α] {n : ℕ} : ↑n < 1 ↔ n = 0 := sorry

@[simp] theorem cast_le_one {α : Type u_1} [ordered_semiring α] [nontrivial α] {n : ℕ} : ↑n ≤ 1 ↔ n ≤ 1 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑n ≤ 1 ↔ n ≤ 1)) (Eq.symm cast_one)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (↑n ≤ ↑1 ↔ n ≤ 1)) (propext cast_le))) (iff.refl (n ≤ 1)))

@[simp] theorem cast_min {α : Type u_1} [linear_ordered_semiring α] {a : ℕ} {b : ℕ} : ↑(min a b) = min ↑a ↑b := sorry

@[simp] theorem cast_max {α : Type u_1} [linear_ordered_semiring α] {a : ℕ} {b : ℕ} : ↑(max a b) = max ↑a ↑b := sorry

@[simp] theorem abs_cast {α : Type u_1} [linear_ordered_ring α] (a : ℕ) : abs ↑a = ↑a :=
  abs_of_nonneg (cast_nonneg a)

theorem coe_nat_dvd {α : Type u_1} [comm_semiring α] {m : ℕ} {n : ℕ} (h : m ∣ n) : ↑m ∣ ↑n :=
  ring_hom.map_dvd (cast_ring_hom α) h

theorem Mathlib.has_dvd.dvd.nat_cast {α : Type u_1} [comm_semiring α] {m : ℕ} {n : ℕ} (h : m ∣ n) : ↑m ∣ ↑n :=
  coe_nat_dvd

theorem inv_pos_of_nat {α : Type u_1} [linear_ordered_field α] {n : ℕ} : 0 < (↑n + 1⁻¹) :=
  iff.mpr inv_pos (add_pos_of_nonneg_of_pos (cast_nonneg n) zero_lt_one)

theorem one_div_pos_of_nat {α : Type u_1} [linear_ordered_field α] {n : ℕ} : 0 < 1 / (↑n + 1) :=
  eq.mpr (id (Eq._oldrec (Eq.refl (0 < 1 / (↑n + 1))) (one_div (↑n + 1)))) inv_pos_of_nat

theorem one_div_le_one_div {α : Type u_1} [linear_ordered_field α] {n : ℕ} {m : ℕ} (h : n ≤ m) : 1 / (↑m + 1) ≤ 1 / (↑n + 1) :=
  one_div_le_one_div_of_le (cast_add_one_pos n)
    (eq.mpr (id (Eq.trans (propext (add_le_add_iff_right 1)) (propext cast_le))) h)

theorem one_div_lt_one_div {α : Type u_1} [linear_ordered_field α] {n : ℕ} {m : ℕ} (h : n < m) : 1 / (↑m + 1) < 1 / (↑n + 1) :=
  one_div_lt_one_div_of_lt (cast_add_one_pos n)
    (eq.mpr (id (Eq.trans (propext (add_lt_add_iff_right 1)) (propext cast_lt))) h)

end nat

namespace add_monoid_hom

theorem ext_nat {A : Type u_1} [add_monoid A] {f : ℕ →+ A} {g : ℕ →+ A} (h : coe_fn f 1 = coe_fn g 1) : f = g := sorry

theorem eq_nat_cast {A : Type u_1} [add_monoid A] [HasOne A] (f : ℕ →+ A) (h1 : coe_fn f 1 = 1) (n : ℕ) : coe_fn f n = ↑n :=
  congr_fun ((fun (this : f = nat.cast_add_monoid_hom A) => this) (ext_nat (Eq.trans h1 (Eq.symm nat.cast_one))))

theorem map_nat_cast {A : Type u_1} {B : Type u_2} [add_monoid A] [HasOne A] [add_monoid B] [HasOne B] (f : A →+ B) (h1 : coe_fn f 1 = 1) (n : ℕ) : coe_fn f ↑n = ↑n := sorry

end add_monoid_hom

namespace ring_hom

@[simp] theorem eq_nat_cast {R : Type u_1} [semiring R] (f : ℕ →+* R) (n : ℕ) : coe_fn f n = ↑n :=
  add_monoid_hom.eq_nat_cast (to_add_monoid_hom f) (map_one f) n

@[simp] theorem map_nat_cast {R : Type u_1} {S : Type u_2} [semiring R] [semiring S] (f : R →+* S) (n : ℕ) : coe_fn f ↑n = ↑n :=
  eq_nat_cast (comp f (nat.cast_ring_hom R)) n

theorem ext_nat {R : Type u_1} [semiring R] (f : ℕ →+* R) (g : ℕ →+* R) : f = g :=
  coe_add_monoid_hom_injective (add_monoid_hom.ext_nat (Eq.trans (map_one f) (Eq.symm (map_one g))))

end ring_hom

@[simp] theorem nat.cast_id (n : ℕ) : ↑n = n :=
  Eq.symm (ring_hom.eq_nat_cast (ring_hom.id ℕ) n)

@[simp] theorem nat.cast_with_bot (n : ℕ) : ↑n = ↑n := sorry

protected instance nat.subsingleton_ring_hom {R : Type u_1} [semiring R] : subsingleton (ℕ →+* R) :=
  subsingleton.intro ring_hom.ext_nat

namespace with_top

@[simp] theorem coe_nat {α : Type u_1} [HasZero α] [HasOne α] [Add α] (n : ℕ) : ↑↑n = ↑n := sorry

@[simp] theorem nat_ne_top {α : Type u_1} [HasZero α] [HasOne α] [Add α] (n : ℕ) : ↑n ≠ ⊤ :=
  eq.mpr (id (Eq._oldrec (Eq.refl (↑n ≠ ⊤)) (Eq.symm (coe_nat n)))) coe_ne_top

@[simp] theorem top_ne_nat {α : Type u_1} [HasZero α] [HasOne α] [Add α] (n : ℕ) : ⊤ ≠ ↑n :=
  eq.mpr (id (Eq._oldrec (Eq.refl (⊤ ≠ ↑n)) (Eq.symm (coe_nat n)))) top_ne_coe

theorem add_one_le_of_lt {i : with_top ℕ} {n : with_top ℕ} (h : i < n) : i + 1 ≤ n := sorry

theorem one_le_iff_pos {n : with_top ℕ} : 1 ≤ n ↔ 0 < n := sorry

theorem nat_induction {P : with_top ℕ → Prop} (a : with_top ℕ) (h0 : P 0) (hsuc : ∀ (n : ℕ), P ↑n → P ↑(Nat.succ n)) (htop : (∀ (n : ℕ), P ↑n) → P ⊤) : P a :=
  option.cases_on a (htop fun (n : ℕ) => nat.rec_on n h0 hsuc) fun (a : ℕ) => (fun (n : ℕ) => nat.rec_on n h0 hsuc) a


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import Lean.Elab.Term
import Lean.Meta.Tactic.Apply
import Lean.Meta.Tactic.Assumption
import Lean.Elab.DeclarationRange
import Mathlib.Control.SimpSet

/-!
# HigherOrder attribute

This file defines the `@[higher_order]` attribute that applies to lemmas of the shape
`∀ x, f (g x) = h x`. It derives an auxiliary lemma of the form `f ∘ g = h` for reasoning about
higher-order functions.
-/

open Lean Name Meta Elab Expr Term

namespace Lean.Parser.Attr

syntax (name := higherOrder) "higher_order" (ppSpace ident)? : attr

end Lean.Parser.Attr

namespace Tactic

/-- `mkComp v e` checks whether `e` is a sequence of nested applications `f (g (h v))`, and if so,
returns the expression `f ∘ g ∘ h`. If `e = v` it returns `id`. -/
def mkComp (v : Expr) : Expr → MetaM Expr
| .app f e =>
  if e.equal v then
    return f
  else do
    if v.occurs f then
      throwError "mkComp failed occurs check"
    let e' ← mkComp v e
    mkAppM ``Function.comp #[f, e']
| e => do
  guard (e.equal v)
  let t ← inferType e
  mkAppOptM ``id #[t]

/--
From a lemma of the shape `∀ x, f (g x) = h x`
derive an auxiliary lemma of the form `f ∘ g = h`
for reasoning about higher-order functions.
-/
partial def mkHigherOrderType (e : Expr) : MetaM Expr := do
  if not e.isForall then
    throwError "not a forall"
  withLocalDecl e.bindingName! e.binderInfo e.bindingDomain! fun fvar => do
    let body := instantiate1 e.bindingBody! fvar
    if body.isForall then
      let exp ← mkHigherOrderType body
      mkForallFVars #[fvar] exp (binderInfoForMVars := e.binderInfo)
    else
      let some (_, lhs, rhs) ← matchEq? body | throwError "not an equality {← ppExpr body}"
      mkEq (← mkComp fvar lhs) (← mkComp fvar rhs)

/-- A user attribute that applies to lemmas of the shape `∀ x, f (g x) = h x`.
It derives an auxiliary lemma of the form `f ∘ g = h` for reasoning about higher-order functions.
-/
def higherOrderGetParam (thm : Name) (stx : Syntax) : AttrM Name := do
  match stx with
  | `(attr| higher_order $[$name]?) =>
    let ref := (name : Option Syntax).getD stx[0]
    let hothmName :=
      if let some sname := name then
        updatePrefix sname.getId thm.getPrefix
      else
        thm.appendAfter "\'"
    MetaM.run' <| TermElabM.run' <| do
      let lvl := (← getConstInfo thm).levelParams
      let typ ← instantiateMVars (← inferType <| .const thm (lvl.map mkLevelParam))
      let hot ← mkHigherOrderType typ
      let prf ← do
        let mvar ← mkFreshExprMVar hot
        let (_, mvarId) ← mvar.mvarId!.intros
        let [mvarId] ← mvarId.apply (← mkConst ``funext) | throwError "failed"
        let (_, mvarId) ← mvarId.intro1
        let lmvr ← mvarId.apply (← mkConst thm)
        lmvr.forM fun mv ↦ mv.assumption
        instantiateMVars mvar
      addDecl <| .thmDecl
        { name := hothmName
          levelParams := lvl
          type := hot
          value := prf }
      addDeclarationRanges hothmName
        { range := ← getDeclarationRange (← getRef)
          selectionRange := ← getDeclarationRange ref }
      _ ← addTermInfo (isBinder := true) ref <| ← mkConstWithLevelParams hothmName
      let hsm := simpExtension.getState (← getEnv) |>.lemmaNames.contains (.decl thm)
      if hsm then
        addSimpTheorem simpExtension hothmName true false .global 1000
      let some fcn ← getSimpExtension? `functor_norm | failure
      let hfm := fcn.getState (← getEnv) |>.lemmaNames.contains <| .decl thm
      if hfm then
        addSimpTheorem fcn hothmName true false .global 1000
      return hothmName
  | _ => throwUnsupportedSyntax

/-- The `higher_order` attribute. From a lemma of the shape `∀ x, f (g x) = h x` derive an
auxiliary lemma of the form `f ∘ g = h` for reasoning about higher-order functions.

Syntax: `[higher_order]` or `[higher_order name]` where the given name is used for the
generated theorem. -/
initialize higherOrderAttr : ParametricAttribute Name ←
  registerParametricAttribute {
    name := `higherOrder,
    descr :=
"From a lemma of the shape `∀ x, f (g x) = h x` derive an auxiliary lemma of the
form `f ∘ g = h` for reasoning about higher-order functions.

Syntax: `[higher_order]` or `[higher_order name]`, where the given name is used for the
generated theorem.",
    getParam := higherOrderGetParam }

end Tactic


import Days
import Days.Common
import Std
import Lean.Data.Parsec
import Init.Data.Format.Basic

open Days
open Days.Common
namespace Days.Day08
def day: ProblemNumber := 8

open Std (RBSet)

/--
The expedition comes across a peculiar patch of tall trees all planted carefully in a grid. The Elves explain that a previous expedition planted these trees as a reforestation effort. Now, they're curious if this would be a good location for a tree house.

First, determine whether there is enough tree cover here to keep a tree house **hidden**. To do this, you need to count the number of trees that are **visible from outside the grid** when looking directly along a row or column.

The Elves have already launched a quadcopter to generate a map with the height of each tree (your puzzle input). For example:

```
30373
25512
65332
33549
35390
```

Each tree is represented as a single digit whose value is its height, where `0` is the shortest and `9` is the tallest.

A tree is **visible** if all of the other trees between it and an edge of the grid are **shorter** than it. Only consider trees in the same row or column; that is, only look up, down, left, or right from any given tree.

All of the trees around the edge of the grid are **visible** - since they are already on the edge, there are no trees to block the view. In this example, that only leaves the **interior nine trees** to consider:

  - The top-left 5 is visible from the left and top. (It isn't visible from the right or bottom since other trees of height 5 are in the way.)
  - The top-middle 5 is visible from the top and right.
  - The top-right 1 is not visible from any direction; for it to be visible, there would need to only be trees of height 0 between it and an edge.
  - The left-middle 5 is visible, but only from the right.
  - The center 3 is not visible from any direction; for it to be visible, there would need to be only trees of at most height 2 between it and an edge.
  - The right-middle 3 is visible from the right.
  - In the bottom row, the middle 5 is visible, but the 3 and 4 are not.

With 16 trees visible on the edge and another 5 visible in the interior, a total of **21** trees are visible in this arrangement.

Consider your map; **how many trees are visible from outside the grid?**
-/
def sample := "30373
25512
65332
33549
35390"

structure Tree where
  height: Nat
  deriving Ord, BEq, DecidableEq, Inhabited, Repr

instance : ToString Tree where
  toString t := toString t.height

instance : LT Tree := ltOfOrd
instance : LE Tree := leOfOrd

structure ForestMap where
  trees: Array $ Array Tree
  deriving BEq, DecidableEq, Inhabited

instance : ToString ForestMap where
  toString map :=
    map.trees
    |>.map (λ row => String.intercalate "" (row |>.map toString |>.toList) )
    |>.toList
    |> String.intercalate "\n"

def ForestMap.parse (lines: List String) : ForestMap :=
  lines
  |>.map (λ line =>
    line.data
    |>.map (λ c => c.toNat - '0'.toNat |> Tree.mk)
    |> #[].appendList)
  |> #[].appendList
  |> ForestMap.mk

def sampleMap := sample |> toInput |>.lines |>.map (·.text) |> ForestMap.parse

#eval sampleMap

def ForestMap.rows (map: ForestMap) : Nat :=
  map.trees.size

def ForestMap.columns (map: ForestMap) : Nat :=
  map.trees[0]!.size

def ForestMap.lastColumn (map: ForestMap) : Nat :=
  map.columns - 1

def ForestMap.lastRow (map: ForestMap) : Nat :=
  map.rows - 1

structure TreeWithPosition extends Tree where
  row: Nat
  col: Nat
  deriving Inhabited

instance : Repr TreeWithPosition where
  reprPrec (tree: TreeWithPosition) _ :=
    .text s!"{tree.height}({tree.row}×{tree.col})"

def ForestMap.walkTrees (map: ForestMap) : Array TreeWithPosition := Id.run <| do
  let mut l : Array TreeWithPosition :=  #[]
  for row in [0:map.rows] do
    for column in [0:map.columns] do
      l := l.push <| TreeWithPosition.mk map.trees[row]![column]! row column
  l

#eval sampleMap.walkTrees |>.size
#eval sampleMap.walkTrees[8]?

inductive Direction where
  | up
  | down
  | left
  | right

def ForestMap.isVibileInDirection (map: ForestMap) (direction: Direction) (pos: TreeWithPosition) : Bool := Id.run <| do
  let (rows, cols) :=
    (match direction with
    | .up => ([:pos.row], [pos.col:pos.col.succ])
    | .down => ([pos.row + 1:map.rows], [pos.col:pos.col.succ])
    | .left => ([pos.row:pos.row.succ], [:pos.col])
    | .right => ([pos.row:pos.row.succ], [pos.col + 1:map.columns]))

  for r in rows do
    for c in cols do
      if map.trees[r]![c]!.height >= pos.height then
        return false

  return true

#eval sampleMap.isVibileInDirection Direction.up {height:=5, col:=1, row:=1}

def ForestMap.isEdgeTree (map: ForestMap) (tree: TreeWithPosition) : Bool :=
  tree.row = 0
  ∨ tree.col = 0
  ∨ tree.row = map.lastRow
  ∨ tree.col = map.lastColumn

def ForestMap.isVisible (map: ForestMap) (tree: TreeWithPosition) : Bool := Id.run <| do
  if map.isEdgeTree tree then true
  else
  for dir in [Direction.up, Direction.down, Direction.left, Direction.right] do
    if map.isVibileInDirection dir tree then return true
  return false

def visibleTrees (map: ForestMap) : Array TreeWithPosition :=
  map.walkTrees
  |>.filter map.isVisible

#eval visibleTrees sampleMap

#eval visibleTrees sampleMap |>.size
#eval visibleTrees sampleMap |>.filter (λ tree => ¬ sampleMap.isEdgeTree tree)

def countVisibleTrees (map: ForestMap) : Nat :=
  visibleTrees map
  |>.size

def part₁ (input: Input) : Nat :=
  input.lines
  |>.map (·.text)
  |> ForestMap.parse
  |> countVisibleTrees

/--
Content with the amount of tree cover available, the Elves just need to know the best spot to build their tree house: they would like to be able to see a lot of trees.

To measure the viewing distance from a given tree, look up, down, left, and right from that tree; stop if you reach an edge or at the first tree that is the same height or taller than the tree under consideration. (If a tree is right on the edge, at least one of its viewing distances will be zero.)

The Elves don't care about distant trees taller than those found by the rules above; the proposed tree house has large eaves to keep it dry, so they wouldn't be able to see higher than the tree house anyway.

In the example above, consider the middle 5 in the second row:

```
30373
25512
65332
33549
35390
```

Looking up, its view is not blocked; it can see 1 tree (of height 3).
Looking left, its view is blocked immediately; it can see only 1 tree (of height 5, right next to it).
Looking right, its view is not blocked; it can see 2 trees.
Looking down, its view is blocked eventually; it can see 2 trees (one of height 3, then the tree of height 5 that blocks its view).
A tree's scenic score is found by multiplying together its viewing distance in each of the four directions. For this tree, this is 4 (found by multiplying 1 * 1 * 2 * 2).

However, you can do even better: consider the tree of height 5 in the middle of the fourth row:

```
30373
25512
65332
33549
35390
```

- Looking up, its view is blocked at 2 trees (by another tree with a height of 5).
- Looking left, its view is not blocked; it can see 2 trees.
- Looking down, its view is also not blocked; it can see 1 tree.
- Looking right, its view is blocked at 2 trees (by a massive tree of height 9).

This tree's scenic score is 8 (2 * 2 * 1 * 2); this is the ideal spot for the tree house.

Consider each tree on your map. What is the highest scenic score possible for any tree?
-/
def toList (range: Std.Range) : List Nat := Id.run <| do
  let mut items := #[]
  for x in range do
    items := items.push x
  return items.toList

def ForestMap.distanceToBlockerInDirection (map: ForestMap) (direction: Direction) (pos: TreeWithPosition) : Nat := Id.run <| do
  let colRange := toList [pos.col:pos.col.succ]
  let rowRange := toList [pos.row:pos.row.succ]
  let (rows, cols) :=
    (match direction with
    | .up => (toList [1:pos.row] |>.reverse, colRange)
    | .down => (toList [pos.row + 1:map.lastRow], colRange)
    | .left => (rowRange, toList [1:pos.col] |>.reverse)
    | .right => (rowRange, toList [pos.col + 1:map.lastColumn]))

  let mut i := 1
  for r in rows do
    for c in cols do
      if map.trees[r]![c]!.height >= pos.height then
        return i
      else i := i+1

  return i

def ForestMap.visibility (map: ForestMap) (tree: TreeWithPosition) : Nat := Id.run <| do
  if map.isEdgeTree tree then 0
  else
  let mut dist := 1
  for dir in [Direction.up, Direction.down, Direction.left, Direction.right] do
    dist := dist * map.distanceToBlockerInDirection dir tree
  return dist

def expectedBest : TreeWithPosition := {height:=5, col:=2, row:=3}
#eval sampleMap.distanceToBlockerInDirection .up expectedBest
#eval sampleMap.distanceToBlockerInDirection .left expectedBest
#eval sampleMap.distanceToBlockerInDirection .down expectedBest
#eval sampleMap.distanceToBlockerInDirection .right expectedBest
#eval sampleMap.visibility expectedBest

def problemTree : TreeWithPosition :=  {height:=6, row:=2, col:=0}
#eval sampleMap.visibility problemTree
#eval sampleMap.distanceToBlockerInDirection .up problemTree
#eval sampleMap.distanceToBlockerInDirection .left problemTree
#eval sampleMap.distanceToBlockerInDirection .down problemTree
#eval sampleMap.distanceToBlockerInDirection .right problemTree

#eval (sampleMap.walkTrees
  |>.map (λ tree => (tree, sampleMap.visibility tree))
  |>.toList)

def bestTreeVisibilityScore (map: ForestMap) : Nat :=
  map.walkTrees
  |>.map (map.visibility ·)
  |>.toList
  |>.maximum?
  |>.get!

#eval bestTreeVisibilityScore sampleMap

def part₂ (input: Input) : Nat :=
  input.lines
  |>.map (·.text)
  |> ForestMap.parse
  |> bestTreeVisibilityScore

def solution : Problem Nat := ⟨ day, part₁, part₂ ⟩

#eval testPart₁ solution sample (expect:=21)
#eval testPart₂ solution sample (expect:=8)


import category_theory.preadditive
import algebraic_topology.cech_nerve

import for_mathlib.simplicial.complex
import for_mathlib.arrow.split

namespace category_theory

universes v u v' u'

namespace arrow

noncomputable theory
open_locale simplicial
open category_theory.limits

variables {C : Type u} [category.{v} C] (f : arrow C)
variables [∀ n : ℕ, has_wide_pullback f.right (λ i : ulift (fin (n+1)), f.left) (λ i, f.hom)]

/-- The splittings of the Cech nerve associated to a split arrow. -/
def cech_splitting [split f] (n : ℕ) : f.cech_nerve _[n] ⟶ f.cech_nerve _[n+1] :=
wide_pullback.lift (wide_pullback.base _)
(λ i, if h : i.down = 0 then wide_pullback.base _ ≫ split.σ else wide_pullback.π _ ⟨i.down.pred h⟩)
begin
  rintro ⟨j⟩,
  split_ifs,
  tidy,
end

lemma cech_splitting_face_zero [split f] (n : ℕ) :
  f.cech_splitting n ≫ f.cech_nerve.δ 0 = 𝟙 _ :=
begin
  ext ⟨j⟩,
  dsimp [cech_splitting, simplicial_object.δ],
  simp only [category.id_comp, category.assoc, wide_pullback.lift_π],
  split_ifs,
  { exfalso,
    exact fin.succ_ne_zero _ h },
  { congr,
    dsimp [simplicial_object.δ, simplex_category.δ],
    simp },
  { dsimp [simplicial_object.δ, cech_splitting],
    simp },
end

lemma face_π (n : ℕ) (i : fin (n+1)) (j : fin (n+2)) :
  (f.cech_nerve.δ j : f.cech_nerve _[n+1] ⟶ _) ≫ wide_pullback.π _ ⟨i⟩ =
  wide_pullback.π _ ⟨j.succ_above i⟩ :=
begin
  change wide_pullback.lift _ _ _ ≫ _ = _,
  simpa,
end

lemma cech_splitting_face [split f] (n : ℕ) (j : fin (n+3)) (hj : j ≠ 0) :
  f.cech_splitting (n+1) ≫ f.cech_nerve.δ j =
  f.cech_nerve.δ (j.pred hj) ≫ f.cech_splitting n :=
begin
  ext ⟨k⟩,
  swap,
  { dsimp [cech_splitting, simplicial_object.δ],
    simp },
  { dsimp [cech_splitting, simplicial_object.δ],
    simp only [category.assoc, limits.wide_pullback.lift_π],
    split_ifs with h1 h2,
    { simp },
    { refine false.elim (h2 _),
      change j.succ_above k = 0 at h1,
      change k = 0,
      rwa ← fin.succ_above_eq_zero_iff hj },
    { refine false.elim (h1 _),
      erw h,
      change j.succ_above 0 = 0,
      rw fin.succ_above_eq_zero_iff hj },
    { simp only [category_theory.limits.wide_pullback.lift_π],
      congr,
      change (j.succ_above k).pred h1 = (j.pred hj).succ_above (k.pred h),
      rw fin.pred_succ_above_pred,
      refl } }
end

end arrow

namespace arrow

section contracting_homotopy

open category_theory.limits opposite

-- Note: Universe restrictions! I hope this doesn't pose any issues later...
-- jmc: seems like it might! I removed them.
variables {P : Type u} {N : Type u'} [category.{v} P] [category.{v'} N] (M : Pᵒᵖ ⥤ N)
variables (f : arrow P)
variables [∀ n : ℕ, has_wide_pullback f.right (λ i : ulift (fin (n+1)), f.left) (λ i, f.hom)]

/-- The augmented Cech conerve induced by applying M to `f.augmented_cech_nerve`. -/
abbreviation conerve : cosimplicial_object.augmented N :=
((cosimplicial_object.augmented.whiskering _ _).obj M).obj f.augmented_cech_nerve.right_op

variables [arrow.split f] [preadditive N]

/-- The morphisms yielding the contracting homotopy. -/
def contracting_homotopy : Π (n : ℕ),
  (f.conerve M).to_cocomplex.X (n+1) ⟶ (f.conerve M).to_cocomplex.X n
| 0 := M.map (wide_pullback.lift (𝟙 _)
         (λ i, (split.σ : f.right ⟶ _))
         (by simp)).op
| (n+1) := M.map (f.cech_splitting n).op

open cosimplicial_object.augmented
open_locale big_operators

lemma is_contracting_homotopy_zero :
  (f.conerve M).to_cocomplex.d 0 1 ≫ f.contracting_homotopy M 0 = 𝟙 _ :=
begin
  dsimp,
  rw if_pos,
  swap, { simp },
  delta conerve,
  dsimp [to_cocomplex_d, to_cocomplex_obj, contracting_homotopy ],
  simp only [category.id_comp, category.comp_id],
  simp_rw [← M.map_comp, ← op_comp, ← M.map_id, ← op_id],
  congr' 2,
  simp,
end

lemma is_contracting_homotopy_one :
  (f.conerve M).to_cocomplex.d 1 2 ≫ f.contracting_homotopy M 1 +
  f.contracting_homotopy M 0 ≫ (f.conerve M).to_cocomplex.d 0 1 = 𝟙 _ :=
begin
  rw ← add_zero (𝟙 ((conerve M f).to_cocomplex.X 1)),
  dsimp only [to_cocomplex, cochain_complex.of],
  rw dif_pos,
  swap, { dec_trivial },
  rw dif_pos,
  swap, { dec_trivial },
  dsimp,
  delta conerve,
  dsimp only [to_cocomplex_d, cosimplicial_object.coboundary, whiskering, whiskering_obj,
    drop, to_cocomplex_obj, comma.snd, cosimplicial_object.whiskering, whiskering_right,
    contracting_homotopy],
  simp_rw fin.sum_univ_succ,
  simp only [fin.coe_zero, fin.sum_univ_zero, fin.coe_one,
    one_zsmul, preadditive.add_comp, pow_one, fin.succ_zero_eq_one,
    category.id_comp, neg_smul, category.comp_id, preadditive.neg_comp, pow_zero ],
  rw [add_assoc],
  congr' 1,
  { dsimp [cosimplicial_object.δ],
    simp_rw [← M.map_comp, ← M.map_id, ← op_id, ← op_comp],
    congr' 2,
    dsimp [cech_splitting],
    ext ⟨j⟩,
    { simp only [wide_pullback.lift_π, category.id_comp, category.assoc],
      split_ifs,
      { cases j,
        dsimp at h,
        injection h with hh,
        simp only [nat.succ_ne_zero] at hh,
        cases hh },
      { congr, } },
    { simp only [wide_pullback.lift_base, category.assoc, category.id_comp] } },
  { dsimp [cosimplicial_object.δ],
    rw [add_assoc, neg_add_eq_zero, ← M.map_comp],
    simp only [zero_comp, category.id_comp, zero_add, functor.map_comp, ← M.map_comp, ← op_comp],
    congr' 2,
    dsimp [cech_splitting],
    ext ⟨j⟩,
    { simp only [wide_pullback.lift_π, category.assoc],
      split_ifs,
      { refl },
      { refine false.elim (h _),
        change (1 : fin 2).succ_above j = 0,
        rw fin.succ_above_eq_zero_iff,
        { simp },
        { exact top_ne_bot } } },
    { simp only [wide_pullback.lift_base, category.assoc, category.comp_id] } }
end

lemma is_contracting_homotopy (n : ℕ) :
  (f.conerve M).to_cocomplex.d (n+2) (n+3) ≫ f.contracting_homotopy M (n+2) +
  f.contracting_homotopy M (n+1) ≫ (f.conerve M).to_cocomplex.d (n+1) (n+2) = 𝟙 _ :=
begin
  dsimp,
  erw if_pos,
  swap, refl,
  dsimp only [to_cocomplex_d],
  rw if_pos,
  swap, refl,
  dsimp only [cosimplicial_object.coboundary],
  simp only [preadditive.sum_comp, preadditive.comp_sum],
  erw [fin.sum_univ_succ, add_assoc, ← finset.sum_add_distrib],
  rw ← add_zero (𝟙 ((conerve M f).to_cocomplex_obj (n + 2))),
  dsimp only [cosimplicial_object.δ],
  congr' 1,
  { delta conerve,
    dsimp [to_cocomplex_obj, contracting_homotopy],
    simp only [category_theory.category.comp_id, one_zsmul, pow_zero],
    simp_rw [← M.map_id, ← M.map_comp, ← op_comp, ← op_id],
    congr' 2,
    apply cech_splitting_face_zero },
  { apply fintype.sum_eq_zero,
    intros i,
    simp only [
      category.comp_id,
      add_zero,
      functor.comp_map,
      fin.coe_succ,
      preadditive.comp_zsmul,
      preadditive.zsmul_comp],
    suffices :
      (drop.obj (conerve M f)).map (simplex_category.δ i.succ) ≫ contracting_homotopy M f (n+2) =
          contracting_homotopy M f (n+1) ≫ (drop.obj (conerve M f)).map (simplex_category.δ i),
    { rw [this, pow_succ],
      simp },
    delta conerve,
    dsimp [contracting_homotopy],
    simp_rw [← M.map_comp, ← op_comp],
    congr' 2,
    convert cech_splitting_face _ _ _ (fin.succ_ne_zero _),
    funext,
    congr,
    simp }
end

end contracting_homotopy

section covariant_contracting_homotopy

open category_theory.limits opposite

variables {P : Type u} {N : Type u'} [category.{v} P] [category.{v'} N] (M : P ⥤ N)
variables (f : arrow P)
variables [∀ n : ℕ, has_wide_pullback f.right (λ i : ulift (fin (n+1)), f.left) (λ i, f.hom)]

/-- The augmented Cech nerve induced by applying M to `f.augmented_cech_nerve`. -/
abbreviation nerve : simplicial_object.augmented N :=
((simplicial_object.augmented.whiskering _ _).obj M).obj f.augmented_cech_nerve

variables [arrow.split f] [preadditive N]

open simplicial_object.augmented
open_locale big_operators

def covariant_contracting_homotopy : Π (n : ℕ),
  (f.nerve M).to_complex.X n ⟶ (f.nerve M).to_complex.X (n+1)
| 0 := M.map $ wide_pullback.lift (𝟙 _) (λ i, (split.σ : f.right ⟶ _)) (by simpa)
| (n+1) := M.map $ f.cech_splitting n

lemma covariant_is_contracting_homotopy_zero :
  f.covariant_contracting_homotopy M 0 ≫ (f.nerve M).to_complex.d 1 0 = 𝟙 _ :=
begin
  dsimp,
  rw if_pos,
  swap, { simp },
  delta nerve,
  dsimp [to_complex_obj, to_complex_d, covariant_contracting_homotopy],
  simp only [category.id_comp, category.comp_id],
  simp_rw [← M.map_comp, ← M.map_id],
  congr' 2,
  simp,
end

lemma covariant_is_contracting_homotopy_one :
  f.covariant_contracting_homotopy M 1 ≫ (f.nerve M).to_complex.d 2 1 +
  (f.nerve M).to_complex.d 1 0 ≫ f.covariant_contracting_homotopy M 0 = 𝟙 _ :=
begin
  dsimp [covariant_contracting_homotopy],
  rw if_pos, rw if_pos, any_goals { dec_trivial },
  dsimp [to_complex_d, simplicial_object.boundary, simplicial_object.δ],
  delta nerve,
  dsimp [to_complex_obj],
  simp only [fin.sum_univ_succ, fin.coe_zero, pow_zero, one_zsmul, fintype.univ_of_subsingleton,
    nat.add_def, fin.mk_eq_subtype_mk, fin.mk_zero, fin.coe_succ, pow_one, neg_smul,
    finset.sum_singleton, preadditive.comp_add, category.id_comp,
    preadditive.comp_neg, category.comp_id],
  simp only [← M.map_comp],
  rw add_assoc,
  convert add_zero _,
  swap,
  { symmetry,
    convert M.map_id _,
    dsimp [arrow.cech_splitting],
    ext ⟨⟨j,hj⟩⟩, simp,
    rw dif_neg, refl,
    dsimp [simplex_category.δ],
    have : j = 0, by simpa using hj, subst this, dec_trivial,
    simp },
  { rw neg_add_eq_zero,
    congr' 1,
    dsimp [cech_splitting],
    ext ⟨⟨j,hj⟩⟩,
    { simp only [category.assoc, wide_pullback.lift_π], dsimp,
      rw dif_pos, have : j = 0, by simpa using hj, subst this,
      dsimp [simplex_category.δ], dec_trivial },
    { simp } }
end

lemma covariant_is_contracting_homotopy (n : ℕ) :
  f.covariant_contracting_homotopy M (n+2) ≫ (f.nerve M).to_complex.d (n+3) (n+2) +
  (f.nerve M).to_complex.d (n+2) (n+1) ≫ f.covariant_contracting_homotopy M (n+1) = 𝟙 _ :=
begin
  dsimp, rw if_pos, rw if_pos, swap, { refl }, swap, { refl },
  simp only [category.comp_id, category.id_comp],
  dsimp only [to_complex_d, simplicial_object.boundary],
  simp only [preadditive.sum_comp, preadditive.comp_sum],
  rw [fin.sum_univ_succ, add_assoc, ← finset.sum_add_distrib],
  convert add_zero _,
  { apply fintype.sum_eq_zero, intros j,
    have : ((j.succ : fin _) : ℕ) = (j : ℕ) + 1 := by simp, rw this, clear this,
    rw [pow_succ],
    simp only [neg_mul, one_mul, neg_smul, preadditive.comp_neg],
    rw neg_add_eq_zero,
    simp only [preadditive.comp_zsmul, preadditive.zsmul_comp],
    congr' 1,
    dsimp [covariant_contracting_homotopy, simplicial_object.δ],
    delta nerve,
    dsimp [whiskering],
    simp only [← M.map_comp],
    congr' 1,
    convert cech_splitting_face _ _ _ (fin.succ_ne_zero _), funext i,
    congr, simp },
  { dsimp [covariant_contracting_homotopy],
    simp only [pow_zero, one_zsmul],
    delta nerve,
    dsimp [arrow.cech_splitting, simplicial_object.whiskering, simplicial_object.δ],
    rw ← M.map_comp, symmetry,
    convert M.map_id _,
    ext ⟨⟨j,hj⟩⟩,
    simp only [category.assoc, wide_pullback.lift_π],
    rw dif_neg, dsimp, simpa, dsimp [simplex_category.δ],
    intro c, apply_fun (λ e, e.1) at c, simpa using c,
    simp, dsimp, simp }
end

end covariant_contracting_homotopy

end arrow

end category_theory


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.monoidal.functorial
import category_theory.monoidal.functor_category
import category_theory.limits.has_limits

/-!
# `lim : (J ⥤ C) ⥤ C` is lax monoidal when `C` is a monoidal category.

When `C` is a monoidal category, the functorial association `F ↦ limit F` is lax monoidal,
i.e. there are morphisms
* `lim_lax.ε : (𝟙_ C) → limit (𝟙_ (J ⥤ C))`
* `lim_lax.μ : limit F ⊗ limit G ⟶ limit (F ⊗ G)`
satisfying the laws of a lax monoidal functor.
-/

open category_theory
open category_theory.monoidal_category

namespace category_theory.limits

universes v u

noncomputable theory

variables {J : Type v} [small_category J]
variables {C : Type u} [category.{v} C] [has_limits C]

instance limit_functorial : functorial (λ F : J ⥤ C, limit F) := { ..limits.lim }

@[simp] lemma limit_functorial_map {F G : J ⥤ C} (α : F ⟶ G) :
  map (λ F : J ⥤ C, limit F) α = limits.lim.map α := rfl

variables  [monoidal_category.{v} C]

@[simps]
instance limit_lax_monoidal : lax_monoidal (λ F : J ⥤ C, limit F) :=
{ ε := limit.lift _ { X := _, π := { app := λ j, 𝟙 _, } },
  μ := λ F G, limit.lift (F ⊗ G)
    { X := limit F ⊗ limit G,
      π :=
      { app := λ j, limit.π F j ⊗ limit.π G j,
        naturality' := λ j j' f,
        begin
          dsimp,
          simp only [category.id_comp, ←tensor_comp, limit.w],
        end, } },
  μ_natural' := λ X Y X' Y' f g,
  begin
    ext, dsimp,
    simp only [limit.lift_π, cones.postcompose_obj_π, monoidal.tensor_hom_app, limit.lift_map,
      nat_trans.comp_app, category.assoc, ←tensor_comp, lim_map_π],
  end,
  associativity' := λ X Y Z,
  begin
    ext, dsimp,
    simp only [limit.lift_π, cones.postcompose_obj_π, monoidal.associator_hom_app, limit.lift_map,
      nat_trans.comp_app, category.assoc],
    slice_lhs 2 2 { rw [←tensor_id_comp_id_tensor], },
    slice_lhs 1 2 { rw [←comp_tensor_id, limit.lift_π], dsimp, },
    slice_lhs 1 2 { rw [tensor_id_comp_id_tensor], },
    conv_lhs { rw [associator_naturality], },
    conv_rhs { rw [←id_tensor_comp_tensor_id (limit.π (Y ⊗ Z) j)], },
    slice_rhs 2 3 { rw [←id_tensor_comp, limit.lift_π], dsimp, },
    dsimp, simp,
  end,
  left_unitality' := λ X,
  begin
    ext, dsimp,
    simp,
    conv_rhs { rw [←tensor_id_comp_id_tensor (limit.π X j)], },
    slice_rhs 1 2 { rw [←comp_tensor_id], erw [limit.lift_π], dsimp, },
    slice_rhs 2 3 { rw [left_unitor_naturality], },
    simp,
  end,
  right_unitality' := λ X,
  begin
    ext, dsimp,
    simp,
    conv_rhs { rw [←id_tensor_comp_tensor_id _ (limit.π X j)], },
    slice_rhs 1 2 { rw [←id_tensor_comp], erw [limit.lift_π], dsimp, },
    slice_rhs 2 3 { rw [right_unitor_naturality], },
    simp,
  end, }

/-- The limit functor `F ↦ limit F` bundled as a lax monoidal functor. -/
def lim_lax : lax_monoidal_functor (J ⥤ C) C := lax_monoidal_functor.of (λ F : J ⥤ C, limit F)

@[simp] lemma lim_lax_obj (F : J ⥤ C) : lim_lax.obj F = limit F := rfl

lemma lim_lax_obj' (F : J ⥤ C) : lim_lax.obj F = lim.obj F := rfl

@[simp] lemma lim_lax_map {F G : J ⥤ C} (α : F ⟶ G) : lim_lax.map α = lim.map α := rfl

@[simp] lemma lim_lax_ε :
  (@lim_lax J _ C _ _ _).ε = limit.lift _ { X := _, π := { app := λ j, 𝟙 _, } } := rfl

@[simp] lemma lim_lax_μ (F G : J ⥤ C) :
  (@lim_lax J _ C _ _ _).μ F G = limit.lift (F ⊗ G)
    { X := limit F ⊗ limit G,
      π :=
      { app := λ j, limit.π F j ⊗ limit.π G j,
        naturality' := λ j j' f,
        begin
          dsimp,
          simp only [category.id_comp, ←tensor_comp, limit.w],
        end, } } := rfl

end category_theory.limits


example (P Q : Type) : P → (Q → P) :=
begin
intro p,
intro q,
exact p,
end


import FOL.language_extension consistency FOL.lindenbaum
open encodable

universes u v

namespace fol
open logic logic.Theory
open_locale logic_symbol

@[simp] lemma app_concat {α β : Type*} (a : α) (s : ℕ → α) (g : α → β) :
  (λ x, g ((a ⌢ s) x)) = g a ⌢ g ∘ s :=
by { funext x, cases x; simp  }

@[simp] lemma app_concat' {α β γ : Type*} (a : α) (s : ℕ → α) (g : α → β) (h : β → γ):
  (λ x, h (g ((a ⌢ s) x))) = h (g a) ⌢ h ∘ g ∘ s :=
by { funext x, cases x; simp  }

open term formula
variables (L : language.{u}) (T : Theory L)

namespace henkin
open language language.extension language.consts_pelimination Theory language.language_translation

@[reducible] def extend : language.{u} := L + consts (formula L)

variables {L}

def henkin_axiom (p : formula L) : formula (extend L) := (∃.↑p) ⟶ rew ı[0 ⇝ p] ↑p

@[reducible] def Theory_extend : Theory (extend L) := ↑T ∪ set.range henkin_axiom

variables {T}

section
open axiomatic_classical_logic axiomatic_classical_logic' provable

variables {S : Theory (extend L)} (Γ : list (formula L))

lemma consistent_of_disjoint (S_consis : S.consistent) (disj : ∀ p ∈ S, disjoint Γ p) (p : formula (extend L)) :
  ¬S ⊢ (∀.[Γ.length] ∼((pelimination' Γ).p 0 p)) → Theory.consistent (S +{ p }) := λ not_b,
begin
  simp [Theory.consistent_iff_bot],
  intros b,
  have : S ⊢ ∼p, from of_equiv_p (deduction.mp b) (equiv_symm $ neg_iff _),
  have : S ⊢ ∀.[Γ.length] ∼(pelimination' Γ).p 0 p,
  { have := provable_pelimination_of_disjoint Γ S (∼p) disj this, simp at this, exact this },
  contradiction
end

lemma tauto (p : formula L) : S ⊢ ∃.((∃.↑p)^1 ⟶ ↑p) :=
begin
  have lmm₁ : S ⊢ (∃.↑p) ⟶ ∃.((∃.↑p)^1 ⟶ ↑p),
  { simp[pnf_imply_ex_iff_fal_imply₁], refine generalize (deduction.mp _),
    refine use #0 _, simp[formula.nested_rew] },
  have lmm₂ : S ⊢ ∼(∃.↑p) ⟶ ∃.((∃.↑p)^1 ⟶ ↑p),
  { refine deduction.mp (use #0 (deduction.mp _)), simp,
    show S +{ ∼∃.↑p } +{ ∃.↑p } ⊢ rew ı[0 ⇝ #0] ↑p,
    exact explosion (show S +{ ∼∃.↑p } +{ ∃.↑p } ⊢ ∃.↑p, by simp) (show S +{ ∼∃.↑p } +{ ∃.↑p } ⊢ ∼∃.↑p, by simp) },
  exact cases_of _ _ lmm₁ lmm₂
end

@[simp] lemma pelimination'_henkin_axiom (p : formula L) : (pelimination' ([p])).p 0 (henkin_axiom p) = ((∃.↑p)^1 ⟶ ↑p) :=
begin
  simp[henkin_axiom, pelimination'_subst, pelimination_coe_eq_pow_coe_aux],
  have : pelim_aux_t ([p]) 0 ↑↑p = (#0 : term (extend L)),
  { have : pelim_aux_t ([p]) 0 ↑p = (#(list.index_of p ([p]) + 0) : term (extend L)), from pelim_aux_t_consts_of_Γ ([p]) p (by simp) 0,
    simp at this, exact this },
  simp[this, formula.nested_rew, show (#0 ⌢ λ x, #(1 + x) : ℕ → term (extend L)) = ı, by { funext x, rcases x; simp[add_comm 1] }],
  simp[formula.pow_eq, add_comm 1]
end

lemma consts_of_henkin_axiom {p : formula L} {c} (mem : c ∈ consts_of_p (henkin_axiom p)) : c = p :=
begin
  simp[henkin_axiom, consts_of_p] at mem,
  rcases mem with ⟨t, (t_mem | t_mem), c_mem⟩,
  { rcases language_translation_coe.fun_p_inversion_of_mem t_mem with ⟨t, t_mem, rfl⟩, simp at c_mem, contradiction },
  { rcases formula.rew_inversion_or_le_of_mem_rew t_mem with (⟨t, t_mem', k, rfl⟩ | ⟨k, n, le⟩),
    { rcases language_translation_coe.fun_p_inversion_of_mem t_mem' with ⟨t, t_mem'', rfl⟩,
      simp[subst_pow] at c_mem,
      rcases mem_of_consts_of_t_subst _ _ _ c_mem with (c_mem | c_mem),
      { simp at c_mem, contradiction },
      {exact eq_of_consts_of_t_coe.mp c_mem } },
    { simp[subst_pow] at le, have : n < k ∨ n = k ∨ k < n , exact trichotomous n k, rcases this with (lt | rfl | lt),
      { simp[lt] at le, simp[le] at c_mem, contradiction },
      { simp[consts.coe_def, show (↑(consts.c p) : (extend L).fn 0) = sum.inr (consts.c p), from rfl, le_iff_lt_or_eq] at le,
        rcases le with (⟨⟨_, A⟩, _⟩ | rfl), { simp at c_mem, exact c_mem } },
      { simp[lt] at le, simp[le] at c_mem, contradiction } } }
end

lemma disjoint_of_ne (p q : formula L) (ne : p ≠ q) : disjoint ([p]) (henkin_axiom q) := λ p mem,
by { simp at mem, rcases mem with rfl, intros mem, have : p = q, from consts_of_henkin_axiom mem, contradiction }

end

theorem Theory_extend_consistent (consis : T.consistent) : (Theory_extend T).consistent :=
begin
  have : (↑T : Theory (extend L)).consistent, from language.add_consts.consistent_iff.mpr consis,
  refine consistent.of_finite_induction this _,
  intros s s_ss φ φ_mem p_nmem s_fin consis',
  let U := ↑T ∪ s,
  rcases φ_mem with ⟨φ, rfl⟩,
  show Theory.consistent (U +{ henkin_axiom φ }),
  have disj : ∀ p ∈ U, disjoint ([φ]) p,
  { intros p mem, simp[U] at mem, rcases mem,
    { rcases mem with ⟨p, mem, rfl⟩, show disjoint ([φ]) (↑p), intros h, simp },
    { have : p ∈ set.range henkin_axiom, from s_ss mem,
      rcases this with ⟨p, rfl⟩,
      have : φ ≠ p, { rintros rfl, contradiction },
      exact disjoint_of_ne _ _ this } },
  have : ¬U ⊢ ∀.∼((∃.↑φ)^1 ⟶ ↑φ),
  { intros b,
    have : U ⊢ ∼∀.∼((∃.↑φ)^1 ⟶ ↑φ), from tauto φ,
    have : ¬U.consistent, { simp[Theory.consistent], refine ⟨_, b, this⟩ },
    contradiction },
  exact consistent_of_disjoint ([φ]) consis' disj (henkin_axiom φ) (by simp; exact this)
end

variables (L) (T)

@[reducible] def Lang : ℕ → language
| 0     := L
| (n+1) := extend (Lang n)

local notation `L[` n `]` := Lang L n

@[reducible] def Consts : Type u := Σ n, formula (Lang L n)

def pConsts (m : ℕ) : Type u := Σ (n : {n | m ≤ n}), formula (Lang L n)

@[reducible] def limit : language := L + consts (Consts L)

local notation `Lω` := limit L

local infix ` ='∘ `:50 := ((=') : term Lω → term Lω → formula Lω)

@[reducible] def Ln_to_Lω : Π n, L[n] ↝ᴸ Lω
| 0     := add_left
| (n+1) := let σ : consts (formula L[n]) ↝ᴸ consts (Consts L) := consts_of_fun (λ p, ⟨n, p⟩) in
    (Ln_to_Lω n).sum (add_right.comp σ)

def pConsts_to_add_pConsts (n : ℕ) : consts (pConsts L n) ↝ᴸ consts (formula L[n]) + consts (pConsts L (n + 1)) :=
{ fn := λ m f, by { rcases m,
    { rcases f with ⟨⟨i, hi⟩, p⟩, simp at hi p,
      by_cases e : i = n,
      { rcases e with rfl, refine sum.inl p },
      { have : n + 1 ≤ i, from nat.succ_le_iff.mpr ((ne.symm e).le_iff_lt.mp hi), refine sum.inr ⟨⟨i, this⟩, p⟩ } },
    { rcases f } },
  pr := λ m r, by { rcases r } }

@[reducible] def Lω_to_Ln_add_pConsts : Π n, Lω ↝ᴸ L[n] + consts (pConsts L n)
| 0       := (1 : L ↝ᴸ L).add (consts_of_fun (λ ⟨n, p⟩, ⟨⟨n, by simp⟩, p⟩))
| (n + 1) :=
  let τ : L[n] + consts (pConsts L n) ↝ᴸ L[n + 1] + consts (pConsts L (n + 1)) := (add_assoc'_inv _ _ _).comp ((1 : L[n] ↝ᴸ L[n]).add ( pConsts_to_add_pConsts L n)) in
    τ.comp (Lω_to_Ln_add_pConsts n)

lemma pConsts_to_add_pConsts_of_eq {n : ℕ} (p : formula L[n]) :
  (pConsts_to_add_pConsts L n).fn 0 (consts.c ⟨⟨n, by { show n ≤ n, by refl }⟩, p⟩) = sum.inl p :=
by simp[pConsts_to_add_pConsts, consts.c]

lemma pConsts_to_add_pConsts_of_lt {n m : ℕ} (p : formula L[m]) (lt : n < m) :
  (pConsts_to_add_pConsts L n).fn 0 (consts.c ⟨⟨m, le_of_lt lt⟩, p⟩) = sum.inr (consts.c ⟨⟨m, nat.succ_le_iff.mpr lt⟩, p⟩) :=
by simp[pConsts_to_add_pConsts, consts.c, show ¬m = n, from ne_of_gt lt]

lemma Lω_to_Ln_add_pConst_fn_of_le {n m : ℕ} (p : formula L[m]) (le : n ≤ m) :
  (Lω_to_Ln_add_pConsts L n).fn 0 (show (consts (Consts L)).fn 0, from ⟨m, p⟩) = sum.inr (consts.c ⟨⟨m, le⟩, p⟩) :=
begin
  simp,
  induction n with n IH generalizing p m; simp[Lω_to_Ln_add_pConsts, ← coe_fn₂],
  { refl },
  { simp[IH p (nat.le_of_succ_le le), ← coe_fn₂],
    have : n < m, from nat.succ_le_iff.mp le,
    simp[pConsts_to_add_pConsts_of_lt L p this, ←coe_fn₂] }
end

lemma commutative (n : ℕ) : (Lω_to_Ln_add_pConsts L n).comp (Ln_to_Lω L n) = add_left :=
begin
  induction n with n IH,
  { ext; simp[Ln_to_Lω, Lω_to_Ln_add_pConsts, add_left_fn_to_coe, add_left_pr_to_coe] },
  { ext m,
    { rcases f; simp[Ln_to_Lω, limit, ←coe_fn₁, ←coe_fn₂],
      { have : (Lω_to_Ln_add_pConsts L n).fn m ((Ln_to_Lω L n).fn m f) = ↑f,
        { have := (language_translation.eq_iff.mp IH).1 m f, simpa using this },
        simp[this, add_left_fn_to_coe] },
      { rcases m,
        { simp[add_right_fn_to_coe],
          have := Lω_to_Ln_add_pConst_fn_of_le L f (by refl), simp at this,
          simp[this, ←coe_fn₂, ←coe_fn₁, add_left_fn_to_coe, pConsts_to_add_pConsts_of_eq L f,
            show (pConsts_to_add_pConsts L n).fn 0 (consts.c ⟨⟨n, show n ≤ n, by refl⟩, f⟩) = _, from pConsts_to_add_pConsts_of_eq L f] },
        { rcases f } } },
    { intros m r, rcases r; simp[Ln_to_Lω, limit, ←coe_pr₁, ←coe_pr₂],
      { have : (Lω_to_Ln_add_pConsts L n).pr m ((Ln_to_Lω L n).pr m r) = ↑r,
        { have := (language_translation.eq_iff.mp IH).2 m r, simpa using this },
        simp[this, add_left_pr_to_coe] },
      { rcases r } } }
end

lemma add_left_Ln_to_Lω_commutative (n : ℕ) : (Ln_to_Lω L (n + 1)).comp (add_left : L[n] ↝ᴸ L[n+1]) = Ln_to_Lω L n :=
by ext; simp[Ln_to_Lω, add_left_fn_to_coe, add_left_pr_to_coe]

variables {L}

def Lω_seq_limit : seq_limit (Lang L) Lω :=
{ seq := λ n, add_left,
  to_limit := Ln_to_Lω L,
  commutes := add_left_Ln_to_Lω_commutative L,
  rank_fn := λ n f, by { rcases f, { exact 0 }, { rcases n, { rcases f with ⟨m, f⟩, exact (m + 1) }, { rcases f } } },
  rank_pr := λ n r, by { rcases r, { exact 0 }, { rcases r } },
  fn := λ n f, by { rcases f, { exact f }, { rcases n, { rcases f with ⟨m, f⟩, exact sum.inr (consts.c f) }, { rcases f } } },
  pr := λ n r, by { rcases r, { exact r }, { rcases r } },
  fn_spec := λ n f, by { rcases f, { refl }, { cases n, { rcases f with ⟨m, f⟩, refl }, { rcases f } } },
  pr_spec := λ n r, by { rcases r, { refl }, { rcases r } } }

def retruct (p : formula Lω) : formula L[Lω_seq_limit.rank_p p] := Lω_seq_limit.retruct_p p

def henkin_constant (p : formula (limit L)) : Consts L := ⟨Lω_seq_limit.rank_p p, retruct L p⟩

@[simp] lemma retruct_s_c (p : formula Lω) : (Ln_to_Lω L _).fun_p (retruct L p) = p := Lω_seq_limit.retruct_p_spec p

@[simp] lemma retruct_s (p : formula Lω) : (Ln_to_Lω L _).fun_p (retruct L p) = p := Lω_seq_limit.retruct_p_spec p

lemma Ln_to_Lω_fun_p_coe (n : ℕ) (p : formula L[n]) :
  (Ln_to_Lω L (n + 1)).fun_p (by simp[Lang]; refine p) = (Ln_to_Lω L n).fun_p p :=
by simp[←add_left_Ln_to_Lω_commutative L n, comp_fun_p]; refl

@[simp] lemma Ln_to_Lω_fun_t_coe {n} (p : formula L[n]) :
  (Ln_to_Lω L (n + 1)).fun_t (↑(↑p : term (consts (formula L[n]))) : term (extend L[n])) = ↑(⟨n, p⟩ : Consts L) :=
begin
  unfold_coes, simp[Ln_to_Lω],
  suffices : ((Ln_to_Lω L n).sum (add_right.comp (consts_of_fun (sigma.mk n)))).fn 0 (↑(consts.c p)) = ↑(consts.c (⟨n, p⟩ : Consts L)),
  { exact this },
  simp, refl
end

variables (T) {L}

@[reducible] def Thy : Π n : ℕ, Theory (Lang L n)
| 0       := T
| (n + 1) := Theory_extend (Thy n)

def Thy' (n : ℕ) := (Ln_to_Lω L n).fun_Theory (Thy T n)

local notation `T[` n `]` := Thy' T n

def Theory_limit : Theory Lω := ⋃ n, T[n]

local notation `Tω` := Theory_limit L T

lemma Thy'_ss (n : ℕ) : T[n] ⊆ T[n + 1] :=
begin
  simp[fun_Theory, Thy', Thy],
  intros p mem, simp[Lang], refine ⟨by simp[Lang]; refine p, _⟩,
  simpa[mem] using Ln_to_Lω_fun_p_coe _ n p,
end

lemma Tn_consistent (consis : T.consistent) (n : ℕ) : Theory.consistent T[n] :=
begin
  have : Theory.consistent (Thy T n),
  { induction n with n IH, { exact consis }, { exact Theory_extend_consistent IH } },
  have consis' : Theory.consistent (add_left.fun_Theory (Thy T n) : Theory (L[n] + consts (pConsts L n))), from add_consts.consistent_iff.mpr this,
  have : (add_left.fun_Theory (Thy T n) : Theory (L[n] + consts (pConsts L n))) = (Lω_to_Ln_add_pConsts L n).fun_Theory T[n],
  { rw[fun_Theory, ←commutative, comp_fun_p, set.image_comp], simp[fun_Theory, Thy'] },
  rw this at consis',
  exact language.language_translation.consistency _ _ consis'
end

theorem Tω_consistent (consis : T.consistent) : Theory.consistent Tω :=
(Theory.consistent.Union_seq (Thy' T) (Thy'_ss T)).mpr (Tn_consistent T consis)

lemma T_ss_Tω : ↑T ⊆ Tω :=
by simpa [show ↑T = T[0], by refl, Theory_limit] using set.subset_Union (Thy' T) 0

lemma henkin_mem_Tω (p : formula Lω) : (∃.p) ⟶ rew ı[0 ⇝ henkin_constant p] p ∈ Tω :=
begin
  simp[henkin_constant],
  let r := Lω_seq_limit.rank_p p,
  suffices : (∃.p) ⟶ rew ı[0 ⇝ henkin_constant p] p ∈ T[r + 1],
  { simp[Theory_limit], refine ⟨_, this⟩ },
  have lmm₁ : (∃.p) ⟶ rew ı[0 ⇝ henkin_constant p] p = (Ln_to_Lω L (r + 1)).fun_p (henkin_axiom (retruct L p)),
  { have := Ln_to_Lω_fun_p_coe L r (retruct L p), simp at this, simp[this, henkin_axiom, henkin_constant] },
  have lmm₂ : (Ln_to_Lω L (r + 1)).fun_p (henkin_axiom (retruct L p)) ∈ T[r + 1],
  { simp[Thy'], refine ⟨henkin_axiom (retruct L p), by simp[Thy], rfl⟩ },
  rw lmm₁, exact lmm₂
end

local notation `Tω⁺` := consistent.maximal Tω

local notation (name := limit) `Lω` := limit _

open axiomatic_classical_logic axiomatic_classical_logic' provable

def Consts.of (t : term Lω) : Consts L := henkin_constant ((t^1) ='∘ #0)
#check Consts.of

def Consts.fn {n} (f : (limit L).fn n) (v : finitary (Consts L) n) : Consts L := Consts.of (app f (λ i, (v i)))

def Consts.pr {n} (r : (limit L).pr n) (v : finitary (Consts L) n) : Prop := formula.app r (λ i, (v i)) ∈ Tω⁺

def Consts.equal (p q : Consts L) : Prop := (p ='∘ q) ∈ Tω⁺

local notation p ` ~[`:50 T :50 `] `:0 q:50 := Consts.equal T p q

variables [cT : Theory.Consistent T] {L}
include cT

lemma Tω_consistent' : Theory.consistent (Theory_limit L T) := Tω_consistent T cT.consis

lemma mem_Tω'_of_Tω_provable {p : formula Lω} (b : Tω ⊢ p): p ∈ Tω⁺ :=
begin
  have : Tω⁺ ⊢ p, from weakening' (Tω_consistent' T).ss_maximal b,
  exact (Tω_consistent' T).mem_maximal_iff.mpr this
end

@[simp, refl] lemma Consts.equal_refl (c : Consts L) : c ~[T] c := by simp[Consts.equal, (Tω_consistent' T).mem_maximal_iff]

theorem Consts.equal_equivalence : equivalence (Consts.equal T) :=
⟨λ p, by simp[Consts.equal, (Tω_consistent' T).mem_maximal_iff],
  λ p q, by { simp[Consts.equal, (Tω_consistent' T).mem_maximal_iff], exact provable.eq_symm },
  λ p q r, by { simp[Consts.equal, (Tω_consistent' T).mem_maximal_iff], exact provable.eq_trans }⟩

lemma Consts.of_eq (t : term Lω) :
 t ='∘ Consts.of t ∈ Tω⁺ :=
begin
  have : ∃.(t^1 ='∘ #0) ⟶ (t ='∘ Consts.of t) ∈ Tω, by simpa[Consts.fn] using henkin_mem_Tω L T (t^1 =' #0),
  have lmm₁ : Tω ⊢ ∃.(t^1 ='∘ #0) ⟶ (t ='∘ Consts.of t), from by_axiom this,
  have lmm₂ : Tω ⊢ ∃.(t^1 ='∘ #0), from provable.use t (by simp),
  have : Tω ⊢ t ='∘ Consts.of t, from lmm₁ ⨀ lmm₂,
  exact mem_Tω'_of_Tω_provable T this
end

lemma Consts.fn_eq {n} (f : (limit L).fn n) (v : finitary (Consts L) n) :
 (app f (λ i, (v i)) ='∘ Consts.fn f v) ∈ Tω⁺ :=
Consts.of_eq _ _

@[reducible, simp, instance]
def henkin : setoid (Consts L) := ⟨Consts.equal T, Consts.equal_equivalence T⟩

def Henkin : Type u := quotient (henkin T)

namespace Henkin
variables {T}

@[elab_as_eliminator]
protected lemma ind_on {C : Henkin T → Prop} (d : Henkin T)
  (h : ∀ p : Consts L, C ⟦p⟧) : C d :=
quotient.induction_on' d h

@[elab_as_eliminator, reducible]
def lift_on {φ} (d : Henkin T) (f : Consts L → φ)
  (h : ∀ p q : Consts L, p ~[T] q → f p = f q) : φ :=
quotient.lift_on' d f h

@[simp]
lemma lift_on_eq {φ} (p : Consts L) (f : Consts L → φ)
  (h : ∀ p q : Consts L, p ~[T] q → f p = f q) : lift_on ⟦p⟧ f h = f p := rfl

@[elab_as_eliminator, reducible, simp]
def lift_on₂ {φ} (d₁ d₂ : Henkin T) (f : Consts L → Consts L → φ)
  (h : ∀ p₁ p₂ q₁ q₂, p₁ ~[T] q₁ → p₂ ~[T] q₂ → f p₁ p₂ = f q₁ q₂) : φ :=
quotient.lift_on₂' d₁ d₂ f h

@[simp] lemma lift_on₂_eq {φ} (p q : Consts L) (f : Consts L → Consts L → φ)
  (h : ∀ p₁ p₂ q₁ q₂, p₁ ~[T] q₁ → p₂ ~[T] q₂ → f p₁ p₂ = f q₁ q₂) :
lift_on₂ ⟦p⟧ ⟦q⟧ f h = f p q := rfl

def lift_on_finitary {φ} {n : ℕ} (v : finitary (Henkin T) n) (f : finitary (Consts L) n → φ)
  (h : ∀ v₁ v₂ : finitary (Consts L) n, (∀ n, (v₁ n) ~[T] (v₂ n)) → f v₁ = f v₂) : φ :=
quotient.lift_on_finitary v f h

@[simp] lemma lift_on_finitary_eq {φ} {n} (v : finitary (Consts L) n) (f : finitary (Consts L) n → φ)
  (h : ∀ v₁ v₂ : finitary (Consts L) n, (∀ n, (v₁ n) ~[T] (v₂ n)) → f v₁ = f v₂) :
  lift_on_finitary (λ x, ⟦v x⟧) f h = f v :=
quotient.lift_on_finitary_eq v f h

@[simp] lemma of_eq_of {p q : Consts L} : (⟦p⟧ : Henkin T) = ⟦q⟧ ↔ p ~[T] q := quotient.eq'

def fn {n} (f : (Lω).fn n) : finitary (Henkin T) n → Henkin T :=
λ v, lift_on_finitary v (λ v, (⟦Consts.fn f v⟧ : Henkin T)) $ λ v₁ v₂ eqs,
begin
  simp[of_eq_of, Consts.equal, (Tω_consistent' T).mem_maximal_iff],
  show      Tω⁺ ⊢ Consts.fn f v₁ ='∘ Consts.fn f v₂,
  have b₁ : Tω⁺ ⊢ app f (λ i, (v₁ i)) ='∘ Consts.fn f v₁, from (Tω_consistent' T).mem_maximal_iff.mp (Consts.fn_eq T f v₁),
  have b₂ : Tω⁺ ⊢ app f (λ i, (v₂ i)) ='∘ Consts.fn f v₂, from (Tω_consistent' T).mem_maximal_iff.mp (Consts.fn_eq T f v₂),
  have b  : Tω⁺ ⊢ app f (λ i, (v₁ i)) ='∘ app f (λ i, (v₂ i)),
  { have : ∀ i, Tω⁺ ⊢ v₁ i ='∘ v₂ i, from λ i, (Tω_consistent' T).mem_maximal_iff.mp (eqs i),
    have : Tω⁺ ⊢ ⋀ i, v₁ i ='∘ v₂ i, refine conjunction_iff.mpr this,
    exact function_ext' f (λ i, (v₁ i)) (λ i, (v₂ i)) ⨀ this },
  exact eq_trans (eq_trans b₁.eq_symm b) b₂
end

@[simp] lemma fn_app {n} (f : (Lω).fn n) (v : finitary (Consts L) n) :
  fn f (λ i, ⟦v i⟧) = ⟦Consts.fn f v⟧ :=
lift_on_finitary_eq _ _ _

def pr {n} (r : (Lω).pr n) : finitary (Henkin T) n → Prop :=
λ v, lift_on_finitary v (Consts.pr T r) $ λ v₁ v₂ eqs,
begin
  simp[of_eq_of, Consts.pr, (Tω_consistent' T).mem_maximal_iff],
  suffices : Tω⁺ ⊢ app r (λ i, (v₁ i)) ⟷ app r (λ i, (v₂ i)),
  { split; intros h, { exact (iff_equiv.mp this).1 ⨀ h }, { exact (iff_equiv.mp this).2 ⨀ h } },
  have : ∀ i, Tω⁺ ⊢ v₁ i ='∘ v₂ i, from λ i, (Tω_consistent' T).mem_maximal_iff.mp (eqs i),
  have : Tω⁺ ⊢ ⋀ i, v₁ i ='∘ v₂ i, refine conjunction_iff.mpr this,
  exact predicate_ext'' r (λ i, (v₁ i)) (λ i, (v₂ i)) ⨀ this
end

@[simp] lemma pr_app {n} (r : (Lω).pr n) (v : finitary (Consts L) n) :
  pr r (λ i, ⟦v i⟧) ↔ formula.app r (λ i, (v i)) ∈ Tω⁺ :=
by { have : pr r (λ i, ⟦v i⟧) = Consts.pr T r v, from lift_on_finitary_eq _ _ _, simp[this, Consts.pr] }

variables (T)

def henkin_model : Structure Lω := ⟨Henkin T, ⟨⟦henkin_constant ⊤⟧⟩, λ n f, fn f, λ n r, pr r⟩

local notation `ℌ` := henkin_model T

@[simp] lemma henkin_model_fn {n} (f : (Lω).fn n) (v) : (ℌ).fn f v = fn f v := rfl
@[simp] lemma henkin_model_pr {n} (r : (Lω).pr n) (v) : (ℌ).pr r v = pr r v := rfl

lemma eq_Consts_of_eq {t u} : Consts.of t ~[T] Consts.of u ↔ Tω⁺ ⊢ t ='∘ u  :=
begin
  simp[Consts.equal, (Tω_consistent' T).mem_maximal_iff],
  have lmm₁ : Tω⁺ ⊢ t ='∘ Consts.of t, from by_axiom (Consts.of_eq T _),
  have lmm₂ : Tω⁺ ⊢ u ='∘ Consts.of u, from by_axiom (Consts.of_eq T _),
  refine ⟨λ h, eq_trans (eq_trans lmm₁ h) (eq_symm lmm₂), λ h, eq_trans (eq_trans (eq_symm lmm₁) h) lmm₂⟩
end

lemma term_val_eq_quotient (t : term Lω) (e : ℕ → Consts L) :
  @term.val _ ℌ (λ n, ⟦e n⟧ : ℕ → (ℌ).dom) t = ⟦Consts.of (t.rew (λ x, ↑(e x)))⟧ :=
begin
  induction t,
  case var : x { simp[Consts.equal], exact Consts.of_eq T _ },
  case app : n f v IH
  { simp,
    have : (λ i, @term.val _ ℌ (λ n, ⟦e n⟧) (v i)) = (λ i, ⟦Consts.of ((v i).rew (λ x, ↑(e x)))⟧),
    { funext i, exact IH i },
    simp[this, Consts.fn],
    have : Tω⁺ ⊢ app f (λ i, (Consts.of ((v i).rew (λ x, (e x))))) ='∘ app f (λ i, (v i).rew (λ x, (e x))),
    { have : ∀ i, Tω⁺ ⊢ Consts.of ((v i).rew (λ x, (e x))) ='∘ (v i).rew (λ x, (e x)),
        from λ i, eq_symm (by_axiom (Consts.of_eq T ((v i).rew (λ x, (e x))))),
      have : Tω⁺ ⊢ ⋀ i, Consts.of ((v i).rew (λ x, (e x))) ='∘ (v i).rew (λ x, (e x)),
        from conjunction_iff.mpr this,
      exact function_ext' f _ _ ⨀ this },
    refine (eq_Consts_of_eq _).mpr this }
end

private lemma ℌ_models_Tω'_fal
  {p : formula Lω}
  (IH : ∀ (s : ℕ → Consts L), p.rew (λ x, ↑(s x)) ∈ Tω⁺ ↔ @formula.val _ ℌ (λ x, ⟦s x⟧) p)
  (s : ℕ → Consts L) :
  (∀.p).rew (λ x, ↑(s x)) ∈ Tω⁺ ↔ ℌ ⊧[λ x, ⟦s x⟧] (∀.p) :=
begin
  simp, split,
    { intros h,  intros c,
      induction c using fol.henkin.Henkin.ind_on,
      let s' : ℕ → Consts L := c ⌢ s,
      have : p.rew (λ x, (s' x)) ∈ Tω⁺,
      { simp[(Tω_consistent' T).mem_maximal_iff] at h ⊢,
        have : Tω⁺ ⊢ p.rew (c ⌢ λ x, (s x)),  simpa[formula.nested_rew] using h ⊚ c,
        simpa using this },
      simpa[s', app_concat c s] using (IH s').1 this },
    { intros h,
      have h : ∀ (c : Consts L), @formula.val _ ℌ (λ x, ⟦(c ⌢ s) x⟧) p, { intros c, simp, exact h ⟦c⟧ },
      by_contradiction A,
      let φ := ∼p.rew ((λ x, (s x))^1),
      have lmm₁ : Tω⁺ ⊢  p.rew (henkin_constant φ ⌢ (λ x, (s x))),
        by simpa using by_axiom ((IH _).mpr (h $ henkin_constant φ)),
      have : Tω⁺ ⊢ ∼∀.p.rew ((λ x, (s x))^1), from by_axiom ((Tω_consistent' T).neg_mem_maximal_iff.mpr A),
      have : Tω⁺ ⊢ ∃.φ, from (iff_of_equiv (provable.neg_fal_equiv_ex_neg _)).mp this,
      have lmm₂ : Tω⁺ ⊢ ∼p.rew (henkin_constant φ ⌢ (λ x, (s x))),
        by simpa[φ, formula.nested_rew] using by_axiom ((Tω_consistent' T).ss_maximal (henkin_mem_Tω L T φ)) ⨀ this,
      exact (Tω_consistent' T).maximal_consistent ⟨_, lmm₁, lmm₂⟩ }
end

theorem ℌ_models_Tω' (p : formula Lω) (s : ℕ → Consts L) :
  p.rew (λ x, ↑(s x)) ∈ Tω⁺ ↔ ℌ ⊧[λ x, ⟦s x⟧] p :=
begin
  induction p generalizing s,
  case app : n r v
  { simp[term_val_eq_quotient, (Tω_consistent' T).mem_maximal_iff],
    suffices :  Tω⁺ ⊢ app r (λ i, (v i).rew (λ x, (s x))) ⟷ app r (λ i, Consts.of ((v i).rew (λ x, (s x)))), from iff_of_equiv this,
    have : ∀ i, Tω⁺ ⊢ (v i).rew (λ x, (s x)) ='∘ Consts.of ((v i).rew (λ x, (s x))),
      from λ i, (by_axiom (Consts.of_eq T ((v i).rew (λ x, (s x))))),
    have :      Tω⁺ ⊢ ⋀ i, (v i).rew (λ x, (s x)) ='∘ Consts.of ((v i).rew (λ x, (s x))),
      from conjunction_iff.mpr this,
    exact predicate_ext'' r _ _ ⨀ this },
  case equal : t u { simp[term_val_eq_quotient, (Tω_consistent' T).mem_maximal_iff], exact iff.symm (eq_Consts_of_eq _) },
  case imply : p q IH_p IH_q { simp[(Tω_consistent' T).imply_mem_maximal_iff] at*, simp[IH_p s, IH_q s] },
  case verum { simp[(Tω_consistent' T).mem_maximal_iff] },
  case neg : p IH { simp[(Tω_consistent' T).neg_mem_maximal_iff], exact iff.not (IH s) },
  case fal : p IH { exact ℌ_models_Tω'_fal T IH s }
end

theorem ℌ_models_Tω'_of_sentence {p : formula Lω} (hp : is_sentence p) :
  p ∈ Tω⁺ ↔ ℌ ⊧ p :=
by simpa[hp, eval_is_sentence_iff] using ℌ_models_Tω' T p default

variables [closed_Theory T]

theorem ℌ_models_T : add_left.of_ltr ℌ ⊧ T :=
begin
  simp[Theory_models_iff], intros p mem,
  have : p ∈ Tω⁺, from (Tω_consistent' T).ss_maximal (T_ss_Tω T mem),
  exact (ℌ_models_Tω'_of_sentence T (show is_sentence p, from closed_Theory.cl mem)).mp this
end

end Henkin

end henkin

variables [closed_Theory T] {L} {T}

theorem consistent_iff_satisfiable : Theory.consistent T ↔ Satisfiable T :=
⟨λ consis,  ⟨_, @henkin.Henkin.ℌ_models_T _ T ⟨consis⟩ _⟩, by { rintros ⟨M, hM⟩, exact Structure_consistent hM}⟩

theorem completeness {p : formula L} (hp : is_sentence p) :
  T ⊢ p ↔ T ⊧ p :=
⟨soundness,
 λ h, by { simp[Theory.provable_iff_inconsistent], intros consis,
  have : closed_Theory (T +{∼p}), from ⟨by { simp[hp], exact λ _, closed_Theory.cl }⟩,
  have : Satisfiable (T +{∼p}), exactI consistent_iff_satisfiable.mp consis,
  rcases this with ⟨M, hM⟩,
  have : M ⊧ p, from consequence_def.mp h M (λ p mem, hM (by simp[mem])),
  have : ¬M ⊧ p, by simpa[models_neg_iff_of_is_sentence hp] using @hM (∼p) (by simp),
  contradiction }⟩

theorem completeness' {p : formula L} :
  T ⊢ p ↔ T ⊧ p :=
⟨soundness,
 λ h, by {
  have : T ⊧ ∀.* p, { intros M hM, simpa using nfal_models_iff.mpr (consequence_def.mp h M hM) },
  have : T ⊢ ∀.* p, from (completeness (show is_sentence (∀.* p), by simp)).mpr this,
  have lmm : T ⊢ p.rew (λ x, ite (x < p.arity) #x #(x - p.arity)), from provable.nfal_subst _ _ ı ⨀ this,
  have := @formula.rew_rew _ p (λ x, ite (x < p.arity) #x #(x - p.arity)) ı (λ m lt, by simp[lt]),
  simpa[this] using lmm }⟩

section
variables {L₁ L₂ : language.{u}} {T₁ : Theory L₁} [closed_Theory T₁]
open language language.language_translation language.language_translation_coe

@[simp] theorem add_coe_consistent_iff :
  (↑T₁ : Theory (L₁ + L₂)).consistent ↔ T₁.consistent :=
⟨language.language_translation.consistency _ T₁,
 λ h,
begin
  have : ∃ M₁, M₁ ⊧ T₁, from consistent_iff_satisfiable.mp h,
  rcases this with ⟨M₁, hM₁⟩,
  let M₂ : Structure (L₁ + L₂) := M₁.extend default default,
  have : M₂ ⊧ (↑T₁ : Theory (L₁ + L₂)), from (M₁.extend_modelsth_coe_iff default default).mpr hM₁,
  exact consistent_iff_satisfiable.mpr ⟨_, this⟩
end⟩

section
variables (L₁ L₂) [language.language_translation_coe L₁ L₂]

@[simp] theorem coe_consistent_iff  :
  (↑T₁ : Theory L₂).consistent ↔ T₁.consistent :=
⟨language.language_translation.consistency _ T₁,
λ h, begin
  have : ∃ M₁, M₁ ⊧ T₁, from consistent_iff_satisfiable.mp h,
  rcases this with ⟨M₁, hM₁⟩,
  let M₂ : Structure (L₁ + sub L₂ L₁) := M₁.extend default default,
  have : M₂ ⊧ (↑T₁ : Theory (L₁ + sub L₂ L₁)), from (M₁.extend_modelsth_coe_iff default default).mpr hM₁,
  have e : (language_equiv.add_sub' L₁ L₂).ltr.fun_Theory ↑T₁ = ↑T₁,
  { have : ((language_equiv.add_sub' L₁ L₂).ltr.comp extension.add_left).fun_Theory T₁ = ltr.fun_Theory T₁,
      by simp[language_equiv.add_sub'_add_left_commute L₁ L₂],
    simpa[comp_fun_Theory] using this },
  have : M₂.of_equiv (language_equiv.add_sub' L₁ L₂) ⊧ ↑T₁,
    by simpa[e] using (Structure.equiv_modelsth_iff (language.language_equiv.add_sub' L₁ L₂)).mpr this,
  exact Structure_consistent this
end⟩

theorem coe_provable_iff (p : formula L₁) (hp : is_sentence p) :
  (↑T₁ : Theory L₂) ⊢ ↑p ↔ T₁ ⊢ p :=
begin
  simp[Theory.provable_iff_inconsistent],
  suffices : ¬Theory.consistent (↑(T₁ +{ ∼p } : Theory L₁) : Theory L₂) ↔ ¬Theory.consistent (T₁ +{ ∼p }),
    by simpa[language.language_translation_coe.fun_Theory_insert] using this,
  have : closed_Theory (T₁ +{ ∼p }) := ⟨by { simp[hp], exact λ _, closed_Theory.cl }⟩,
  have : Theory.consistent (↑(T₁ +{ ∼p } : Theory L₁) : Theory L₂) ↔ Theory.consistent (T₁ +{ ∼p }),
    by exactI coe_consistent_iff L₁ L₂,
  simp[this]
end

@[simp] theorem coe_provable_iff' {p : formula L₁} :
  (↑T₁ : Theory L₂) ⊢ ↑p ↔ T₁ ⊢ p :=
by { have : (↑T₁ : Theory L₂) ⊢ ↑∀.* p ↔ T₁ ⊢ ∀.* p, from coe_provable_iff L₁ L₂ (∀.* p) (by simp),
      simpa[←provable.iff_fal_complete] using this }

end

section
-- Extensions by definitions
variables {L₁ L₂} (D : L₁.definitions L₂)

theorem extensions_by_definitions_consistent (consis : T₁.consistent)
  (b : ∀ {n} (f : L₂.fn n), T₁ ⊢ ∀.[n] ∃.(D.df_fn f)) :
  Theory.consistent (↑T₁ ∪ D.thy) :=
begin
  suffices : ∃ M, M ⊧ (↑T₁ ∪ D.thy),
  { exactI consistent_iff_satisfiable.mpr this },
  have : ∃ M, M ⊧ T₁, from consistent_iff_satisfiable.mp consis,
  rcases this with ⟨M, hM⟩,
  have : ∀ (n) (f : L₂.fn n) (v : finitary M.dom n), ∃ (d : M.dom),
    (D.df_fn f).val M (d ⌢ (λ i, if h : i < n then v ⟨i, h⟩ else default)),
  { intros n f,
    have : M ⊧[default] ∀.[n] ∃.(D.df_fn f), from (soundness (b f) hM) default,
    simpa[models_univs] using this },
  have : ∀ n : ℕ, ∃ F' : L₂.fn n → finitary M.dom n → M.dom,
    ∀ (f : L₂.fn n) (v : finitary M.dom n), (D.df_fn f).val M (F' f v ⌢ (λ i, if h : i < n then v ⟨i, h⟩ else default)),
  { intros n, choose F' hF' using this n, exact ⟨F', hF'⟩ },
  choose F hF using this,
  let R : Π n, L₂.pr n → finitary M.dom n → Prop := λ n r v, M ⊧[λ i, if h : i < n then v ⟨i, h⟩ else default] (D.df_pr r),
  let M₂ : Structure (L₁ + L₂) := M.extend F R,
  have lmm₁ : ∀ {n} (f : L₂.fn n), M₂ ⊧ def_fn f (D.df_fn f),
  { intros n f,
    rw [←eval_is_sentence_iff default (show is_sentence (def_fn f (D.df_fn f)), by simp[D.hdf_fn])],
    simp[def_fn, models_univs], intros v,
    exact (Structure.extend_val_coe_iff M _ _).mpr (hF n f v) },
  have lmm₂ : ∀ {n} (r : L₂.pr n), M₂ ⊧ def_pr r (D.df_pr r),
  { intros n r,
    rw [←eval_is_sentence_iff default (show is_sentence (def_pr r (D.df_pr r)), by simp[D.hdf_pr])],
    simp[def_pr, models_univs, R], intros v,
    exact iff.symm (Structure.extend_val_coe_iff M F R), exact ⟨λ _, default⟩ },
  have lmm₃ : M₂ ⊧ ↑T₁, from (Structure.extend_modelsth_coe_iff M _ _).mpr hM,
  refine ⟨M₂, by { simp[lmm₃, definitions_def], split; intros n; simp[logic.semantics.Models_def, lmm₁, lmm₂] }⟩
end

variables (T₁)

theorem extensions_by_definitions_consistent_iff
  (b : ∀ {n} (f : L₂.fn n), T₁ ⊢ ∀.[n] ∃.(D.df_fn f)) :
  Theory.consistent (↑T₁ ∪ D.thy) ↔ T₁.consistent :=
⟨λ h, begin
  have : (↑T₁ : Theory (L₁ + L₂)).consistent, from Theory.consistent_of_consistent_ss h (by simp),
  exact add_coe_consistent_iff.mp this
end, λ h,  extensions_by_definitions_consistent D h @b⟩

theorem extensions_by_definitions_conservative
  (b : ∀ {n} (f : L₂.fn n), T₁ ⊢ ∀.[n] ∃.(D.df_fn f))
  (p : formula L₁) (hp : p.is_sentence) :
  ↑T₁ ∪ D.thy ⊢ p ↔ T₁ ⊢ p :=
begin
  simp[Theory.provable_iff_inconsistent],
  suffices : ¬Theory.consistent (↑(T₁+{ ∼p }) ∪ D.thy) ↔ ¬Theory.consistent (T₁+{ ∼p }),
  { have eq : ((↑T₁ ∪ D.thy) +{ ∼↑p }) = (↑(T₁+{ ∼p }) ∪ D.thy),
    { ext q, simp[language.language_translation_coe.fun_Theory_insert, or_assoc] },
    simpa[eq] using this },
  have : closed_Theory (T₁ +{ ∼p }) := ⟨by { simp[hp], exact λ _, closed_Theory.cl }⟩,
  exact iff.not (by exactI extensions_by_definitions_consistent_iff (T₁+{ ∼p }) D (λ n f, by simp[b f]))
end

theorem extensions_by_definitions_conservative'
  (b : ∀ {n} (f : L₂.fn n), T₁ ⊢ ∀.[n] ∃.(D.df_fn f))
  (p : formula L₁) :
  ↑T₁ ∪ D.thy ⊢ p ↔ T₁ ⊢ p :=
by { have := extensions_by_definitions_conservative T₁ D @b (∀.* p) (by simp),
     simpa[←provable.iff_fal_complete] using this }

theorem extensions_by_definitions_consistent_iff_of_predicate [language.predicate L₂] :
  Theory.consistent (↑T₁ ∪ D.thy) ↔ T₁.consistent :=
extensions_by_definitions_consistent_iff T₁ D (λ n f, by { exfalso, exact is_empty.false f })

end

end

end fol


import category_theory.functor.category
import category_theory.eq_to_hom

open category_theory

namespace category_theory

namespace functor

--lemma congr_obj {D D' : Type*} [category D] [category D'] {F G : D ⥤ D'}
--(h : F = G) : ∀ X : D, F.obj X = G.obj X :=
--by { intro X, rw h, }

--lemma congr_map {D D' : Type*} [category D] [category D'] (F : D ⥤ D')
--{X Y : D} {f g : X ⟶ Y} (h : f = g) : F.map f = F.map g :=
--by { subst h, }

lemma assoc_eq {C₁ C₂ C₃ C₄ : Type*} [category C₁] [category C₂] [category C₃] [category C₄]
  (F : C₁ ⥤ C₂) (G : C₂ ⥤ C₃) (H : C₃ ⥤ C₄) :
  (F ⋙ G) ⋙ H = F ⋙ (G ⋙ H) := rfl

end functor

end category_theory