section
variables {α : Type*} [semiring α]

theorem mul_two_eq_add_self (x : α) : x * 2 = x + x :=
show x * (1 + 1) = x + x, by rw [mul_add, mul_one]

theorem two_mul_eq_add_self (x : α) : 2 * x = x + x :=
show (1 + 1) * x = x + x, by rw [add_mul, one_mul]

end

namespace linear_ordered_ring
variables (α : Type*) [i : linear_ordered_ring α]
include i

lemma one_pos : (0:α) < 1 := zero_lt_one α

lemma two_pos : (0:α) < 2 := _root_.add_pos (one_pos α) (one_pos α)

variable {α}

lemma add_pos (x y : α) : 0 < x → 0 < y → 0 < x + y := _root_.add_pos

lemma succ_pos (x : α) : 0 < x → 0 < x + 1 := λ h, add_pos x 1 h (one_pos α)

-- linear_ordered_ring.mul_pos (x y : α) : 0 < x → 0 < y → 0 < x * y

lemma bit0_pos (x : α) : 0 < x → 0 < bit0 x := λ h, add_pos x x h h

lemma bit1_pos (x : α) : 0 < x → 0 < bit1 x := λ h, succ_pos (bit0 x) (bit0_pos x h)

class num_pos (x : α) := (elim : (0:α) < x)

namespace num_pos
variable {i}

@[priority 30] instance one : @num_pos α i (1:α) := ⟨one_pos α⟩
@[priority 30] instance two : @num_pos α i (2:α) := ⟨two_pos α⟩
@[priority 30] instance bit0 (x : α) [@num_pos α i x] : @num_pos α i (bit0 x) := ⟨bit0_pos x (elim x)⟩
@[priority 30] instance bit1 (x : α) [@num_pos α i x] : @num_pos α i (bit1 x) := ⟨bit1_pos x (elim x)⟩
@[priority 10] instance succ (x : α) [@num_pos α i x] : @num_pos α i (x+1) := ⟨succ_pos x (elim x)⟩
@[priority 20] instance add (x y : α) [@num_pos α i x] [@num_pos α i y] : @num_pos α i (x + y) := ⟨add_pos x y (elim x) (elim y)⟩
@[priority 30] instance mul (x y : α) [@num_pos α i x] [@num_pos α i y] : @num_pos α i (x * y) := ⟨mul_pos x y (elim x) (elim y)⟩

end num_pos

end linear_ordered_ring

theorem pos_trivial {α : Type*} [linear_ordered_ring α] (x : α) [linear_ordered_ring.num_pos x] : (0:α) < x := linear_ordered_ring.num_pos.elim x

section
variables {α : Type*} [linear_ordered_ring α]

theorem le_of_mul_ge_mul_left {a b c : α} : c * b ≤ c * a → c < 0 → a ≤ b :=
begin
intros h hc,
have hc : -c > 0 := neg_pos_of_neg hc,
apply le_of_mul_le_mul_left _ hc,
apply le_of_neg_le_neg,
rw [neg_mul_eq_neg_mul, neg_mul_eq_neg_mul, neg_neg],
assumption,
end

theorem le_of_mul_ge_mul_right {a b c : α} : b * c ≤ a * c → c < 0 → a ≤ b :=
begin
intros h hc,
have hc : -c > 0 := neg_pos_of_neg hc,
apply le_of_mul_le_mul_right _ hc,
apply le_of_neg_le_neg,
rw [neg_mul_eq_mul_neg, neg_mul_eq_mul_neg, neg_neg],
assumption,
end

end

section
variables {α : Type*} [linear_ordered_field α]

theorem div_le_of_le_mul_of_pos {x y : α} (z : α) : x ≤ y*z → 0 < z → x/z ≤ y :=
begin
intros hm hz,
apply le_of_mul_le_mul_right _ hz,
transitivity x,
{ apply le_of_eq,
  apply div_mul_cancel,
  apply ne_of_gt,
  assumption },
{ assumption },
end

theorem le_div_of_mul_le_of_pos {x y : α} (z : α) : x*z ≤ y → 0 < z → x ≤ y/z :=
begin
intros hm hz,
apply le_of_mul_le_mul_right _ hz,
transitivity y,
{ assumption },
{ apply le_of_eq,
  symmetry,
  apply div_mul_cancel,
  apply ne_of_gt,
  assumption },
end

theorem le_div_of_mul_ge_of_neg {x y : α} (z : α) : y ≤ x*z → z < 0 → x ≤ y/z :=
begin
intros hm hz,
apply le_of_mul_ge_mul_right _ hz,
transitivity y,
{ apply le_of_eq,
  apply div_mul_cancel,
  apply ne_of_lt,
  assumption },
{ assumption },
end

theorem div_le_of_ge_mul_of_neg {x y : α} (z : α) : y*z ≤ x → z < 0 → x/z ≤ y :=
begin
intros hm hz,
apply le_of_mul_ge_mul_right _ hz,
transitivity x,
{ assumption },
{ apply le_of_eq,
  symmetry,
  apply div_mul_cancel,
  apply ne_of_lt,
  assumption },
end

end

namespace order

inductive {u} lt_cmp {α : Type u} [has_lt α] (x y : α) : Type u
| eq : x = y → lt_cmp
| lt : x < y → lt_cmp
| gt : y < x → lt_cmp

inductive {u} le_cmp {α : Type u} [has_le α] (x y : α) : Type u
| le : x ≤ y → le_cmp
| ge : y ≤ x → le_cmp

variables {α : Type*} [decidable_linear_order α]

def lt_compare (x y : α) : lt_cmp x y :=
if hlt : x < y then
lt_cmp.lt hlt
else if hgt : y < x then
lt_cmp.gt hgt
else
lt_cmp.eq $ le_antisymm (le_of_not_gt hgt) (le_of_not_gt hlt)

def le_compare (x y : α) : le_cmp x y :=
if h : x < y then
le_cmp.le (le_of_lt h)
else
le_cmp.ge (le_of_not_gt h)

@[elab_as_eliminator]
def trichotomy_on (x y : α) {C : Sort*} : (x = y → C) → (x < y → C) → (y < x → C) → C :=
λ heq hlt hgt, lt_cmp.cases_on (lt_compare x y) heq hlt hgt

@[elab_as_eliminator]
def dichotomy_on (x y : α) {C : Sort*} : (x ≤ y → C) → (y ≤ x → C) → C :=
λ hle hge, le_cmp.cases_on (le_compare x y) hle hge

end order

namespace tactic
open interactive

/--
`by_trichotomy (x, y)` splits the goal into three branches, the first assuming `x = y`,
the second assuming `x < y` and the third assuming `y < x`.

This tactic requires that terms `x` and `y` have the same type and that this type has
`decidable_linear_order` instance.
-/
meta def interactive.by_trichotomy : parse types.texpr → tactic unit :=
λ e, do {
  `(@prod.mk %%t %%.(t) %%x %%y) ← to_expr e,
  d ← to_expr ``(decidable_linear_order %%t) >>= mk_instance
    <|> fail ("cannot find decidable_linear_order instance for type " ++ to_string t),
  to_expr ``(@order.trichotomy_on %%t %%d %%x %%y) >>= apply >> skip
}

/--
`by_trichotomy (x, y)` splits the goal into two branches, the first assuming `x ≤ y`
and the second assuming `y ≤ x`.

This tactic requires that terms `x` and `y` have the same type and that this type has
`decidable_linear_order` instance.
-/
meta def interactive.by_dichotomy : parse types.texpr → tactic unit :=
λ e, do {
  `(@prod.mk %%t %%.(t) %%x %%y) ← to_expr e,
  d ← to_expr ``(decidable_linear_order %%t) >>= mk_instance
    <|> fail ("cannot find decidable_linear_order instance for " ++ to_string t),
  to_expr ``(@order.dichotomy_on %%t %%d %%x %%y) >>= apply >> skip
}

end tactic


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import tactic.core
import tactic.lint
/-!
# mk_iff_of_inductive_prop

This file defines a tactic `tactic.mk_iff_of_inductive_prop` that generates `iff` rules for
inductive `Prop`s. For example, when applied to `list.chain`, it creates a declaration with
the following type:

```lean
∀{α : Type*} (R : α → α → Prop) (a : α) (l : list α),
  chain R a l ↔ l = [] ∨ ∃{b : α} {l' : list α}, R a b ∧ chain R b l ∧ l = b :: l'
```

This tactic can be called using either the `mk_iff_of_inductive_prop` user command or
the `mk_iff` attribute.
-/

open tactic expr
namespace mk_iff

/-- `select m n` runs `tactic.right` `m` times, and then `tactic.left` `(n-m)` times.
Fails if `n < m`. -/
meta def select : ℕ → ℕ → tactic unit
| 0 0             := skip
| 0 (n + 1)       := left >> skip
| (m + 1) (n + 1) := right >> select m n
| (n + 1) 0       := failure

/-- `compact_relation bs as_ps`: Produce a relation of the form:
```lean
R as := ∃ bs, Λ_i a_i = p_i[bs]
```
This relation is user-visible, so we compact it by removing each `b_j` where a `p_i = b_j`, and
hence `a_i = b_j`. We need to take care when there are `p_i` and `p_j` with `p_i = p_j = b_k`.

TODO: this is a variant of `compact_relation` in `coinductive_predicates.lean`, export it there.
-/
meta def compact_relation :
  list expr → list (expr × expr) → list (option expr) × list (expr × expr)
| []        ps := ([], ps)
| (b :: bs) ps :=
  match ps.span (λap:expr × expr, ¬ ap.2 =ₐ b) with
    | (_, [])              := let (bs, ps) := compact_relation bs ps in (b::bs, ps)
    | (ps₁, (a, _) :: ps₂) :=
      let i := a.instantiate_local b.local_uniq_name,
        (bs, ps) := compact_relation (bs.map i) ((ps₁ ++ ps₂).map (λ⟨a, p⟩, (a, i p)))
      in (none :: bs, ps)
  end

@[nolint doc_blame] -- TODO: document
meta def constr_to_prop (univs : list level) (g : list expr) (idxs : list expr) (c : name) :
  tactic ((list (option expr) × (expr ⊕ ℕ)) × expr) :=
do e ← get_env,
  decl ← get_decl c,
  some type' ← return $ decl.instantiate_type_univ_params univs,
  type ← drop_pis g type',
  (args, res) ← open_pis type,
  let idxs_inst := res.get_app_args.drop g.length,
  let (bs, eqs) := compact_relation args (idxs.zip idxs_inst),
  let bs' := bs.filter_map id,
  eqs ← eqs.mmap (λ⟨idx, inst⟩, do
    let ty := idx.local_type,
    inst_ty ← infer_type inst,
    sort u ← infer_type ty,
    (is_def_eq ty inst_ty >> return ((const `eq [u] : expr) ty idx inst)) <|>
      return ((const `heq [u] : expr) ty idx inst_ty inst)),
  (n, r) ← match bs', eqs with
  | [], [] := return (sum.inr 0, mk_true)
  | _, []  := do
    let t : expr := bs'.ilast.local_type,
    sort l ← infer_type t,
    if l = level.zero then do
      r ← mk_exists_lst bs'.init t,
      return (sum.inl bs'.ilast, r)
    else do
      r ← mk_exists_lst bs' mk_true,
      return (sum.inr 0, r)
  | _, _ := do
    r ← mk_exists_lst bs' (mk_and_lst eqs),
    return (sum.inr eqs.length, r)
  end,
  return ((bs, n), r)

@[nolint doc_blame] -- TODO: document
meta def to_cases (s : list $ list (option expr) × (expr ⊕ ℕ)) : tactic unit :=
do h ← intro1,
  i ← induction h,
  focus ((s.zip i).enum.map $ λ⟨p, (shape, t), _, vars, _⟩, do
    let si := (shape.zip vars).filter_map (λ⟨c, v⟩, c >>= λ _, some v),
    select p (s.length - 1),
    match t with
    | sum.inl e := do
      si.init.mmap' existsi,
      some v ← return $ vars.nth (shape.length - 1),
      exact v
    | sum.inr n := do
      si.mmap' existsi,
      iterate_exactly (n - 1) (split >> constructor >> skip) >> constructor >> skip
    end,
    done),
  done

/--
Iterate over two lists, if the first element of the first list is `none`, insert `none` into the
result and continue with the tail of first list. Otherwise, wrap the first element of the second
list with `some` and continue with the tails of both lists. Return when either list is empty.

Example:
```
list_option_merge [none, some (), none, some ()] [0, 1, 2, 3, 4] = [none, (some 0), none, (some 1)]
```
-/
def list_option_merge {α : Type*} {β : Type*} : list (option α) → list β → list (option β)
| [] _ := []
| (none :: xs) ys := none :: list_option_merge xs ys
| (some _ :: xs) (y :: ys) := some y :: list_option_merge xs ys
| (some _ :: xs) [] := []

@[nolint doc_blame] -- TODO: document
meta def to_inductive
  (cs : list name) (gs : list expr) (s : list (list (option expr) × (expr ⊕ ℕ))) (h : expr) :
  tactic unit :=
match s.length with
| 0       := induction h >> skip
| (n + 1) := do
  r ← elim_gen_sum n h,
  focus ((cs.zip (r.zip s)).map $ λ⟨constr_name, h, bs, e⟩, do
    let n := (bs.filter_map id).length,
    match e with
    | sum.inl e := elim_gen_prod (n - 1) h [] [] >> skip
    | sum.inr 0 := do
      (hs, h, _) ← elim_gen_prod n h [] [],
      clear h
    | sum.inr (e + 1) := do
      (hs, h, _) ← elim_gen_prod n h [] [],
      (es, eq, _) ← elim_gen_prod e h [] [],
      let es := es ++ [eq],
      /- `es.mmap' subst`: fails when we have dependent equalities (`heq`). `subst` will change the
        dependent hypotheses, so that the `uniq` local names in `es` are wrong afterwards. Instead
        we revert them and pull them out one-by-one. -/
      revert_lst es,
      es.mmap' (λ_, intro1 >>= subst)
    end,
    ctxt ← local_context,
    let gs := ctxt.take gs.length,
    let hs := (ctxt.reverse.take n).reverse,
    let m := gs.map some ++ list_option_merge bs hs,
    args ← m.mmap (λa, match a with some v := return v | none := mk_mvar end),
    c ← mk_const constr_name,
    exact (c.mk_app args),
    done),
  done
end

end mk_iff

namespace tactic
open mk_iff

/--
`mk_iff_of_inductive_prop i r` makes an `iff` rule for the inductively-defined proposition `i`.
The new rule `r` has the shape `∀ps is, i as ↔ ⋁_j, ∃cs, is = cs`, where `ps` are the type
parameters, `is` are the indices, `j` ranges over all possible constructors, the `cs` are the
parameters for each of the constructors, and the equalities `is = cs` are the instantiations for
each constructor for each of the indices to the inductive type `i`.

In each case, we remove constructor parameters (i.e. `cs`) when the corresponding equality would
be just `c = i` for some index `i`.

For example, `mk_iff_of_inductive_prop` on `list.chain` produces:

```lean
∀ {α : Type*} (R : α → α → Prop) (a : α) (l : list α),
  chain R a l ↔ l = [] ∨ ∃{b : α} {l' : list α}, R a b ∧ chain R b l ∧ l = b :: l'
```
-/
meta def mk_iff_of_inductive_prop (i : name) (r : name) : tactic unit :=
do e ← get_env,
  guard (e.is_inductive i),
  let constrs := e.constructors_of i,
  let params := e.inductive_num_params i,
  let indices := e.inductive_num_indices i,
  let rec := match e.recursor_of i with
    | some rec := rec
    | none := i.append `rec
    end,
  decl ← get_decl i,
  let type := decl.type,

  let univ_names := decl.univ_params,
  let univs := univ_names.map level.param,
    /- we use these names for our universe parameters, maybe we should construct a copy of them
    using `uniq_name` -/

  (g, `(Prop)) ← open_pis type | fail "Inductive type is not a proposition",
  let lhs := (const i univs).mk_app g,
  shape_rhss ← constrs.mmap (constr_to_prop univs (g.take params) (g.drop params)),
  let shape := shape_rhss.map prod.fst,
  let rhss := shape_rhss.map prod.snd,
  add_theorem_by r univ_names ((mk_iff lhs (mk_or_lst rhss)).pis g) (do
    gs ← intro_lst (g.map local_pp_name),
    split,
    focus' [to_cases shape, intro1 >>= to_inductive constrs (gs.take params) shape]),
  skip

end tactic

section
setup_tactic_parser

/--
`mk_iff_of_inductive_prop i r` makes an `iff` rule for the inductively-defined proposition `i`.
The new rule `r` has the shape `∀ps is, i as ↔ ⋁_j, ∃cs, is = cs`, where `ps` are the type
parameters, `is` are the indices, `j` ranges over all possible constructors, the `cs` are the
parameters for each of the constructors, and the equalities `is = cs` are the instantiations for
each constructor for each of the indices to the inductive type `i`.

In each case, we remove constructor parameters (i.e. `cs`) when the corresponding equality would
be just `c = i` for some index `i`.

For example, `mk_iff_of_inductive_prop` on `list.chain` produces:

```lean
∀ {α : Type*} (R : α → α → Prop) (a : α) (l : list α),
  chain R a l ↔ l = [] ∨ ∃{b : α} {l' : list α}, R a b ∧ chain R b l ∧ l = b :: l'
```

See also the `mk_iff` user attribute.
-/
@[user_command] meta def mk_iff_of_inductive_prop_cmd (_ : parse (tk "mk_iff_of_inductive_prop")) :
  parser unit :=
do i ← ident, r ← ident, tactic.mk_iff_of_inductive_prop i r

add_tactic_doc
{ name        := "mk_iff_of_inductive_prop",
  category    := doc_category.cmd,
  decl_names  := [``mk_iff_of_inductive_prop_cmd],
  tags        := ["logic", "environment"] }

/--
Applying the `mk_iff` attribute to an inductively-defined proposition `mk_iff` makes an `iff` rule
`r` with the shape `∀ps is, i as ↔ ⋁_j, ∃cs, is = cs`, where `ps` are the type parameters, `is` are
the indices, `j` ranges over all possible constructors, the `cs` are the parameters for each of the
constructors, and the equalities `is = cs` are the instantiations for each constructor for each of
the indices to the inductive type `i`.

In each case, we remove constructor parameters (i.e. `cs`) when the corresponding equality would
be just `c = i` for some index `i`.

For example, if we try the following:
```lean
@[mk_iff] structure foo (m n : ℕ) : Prop :=
(equal : m = n)
(sum_eq_two : m + n = 2)
```

Then `#check foo_iff` returns:
```lean
foo_iff : ∀ (m n : ℕ), foo m n ↔ m = n ∧ m + n = 2
```

You can add an optional string after `mk_iff` to change the name of the generated lemma.
For example, if we try the following:
```lean
@[mk_iff bar] structure foo (m n : ℕ) : Prop :=
(equal : m = n)
(sum_eq_two : m + n = 2)
```

Then `#check bar` returns:
```lean
bar : ∀ (m n : ℕ), foo m n ↔ m = n ∧ m + n = 2
```

See also the user command `mk_iff_of_inductive_prop`.
-/
@[user_attribute] meta def mk_iff_attr : user_attribute unit (option name) :=
{ name := `mk_iff,
  descr := "Generate an `iff` lemma for an inductive `Prop`.",
  parser := ident?,
  after_set := some $ λ n _ _, do
    tgt ← mk_iff_attr.get_param n,
    tactic.mk_iff_of_inductive_prop n (tgt.get_or_else (n.append_suffix "_iff")) }

add_tactic_doc
{ name        := "mk_iff",
  category    := doc_category.attr,
  decl_names  := [`mk_iff_attr],
  tags        := ["logic", "environment"] }

end


import .formula
import .semantics
import .tactics

/-- A formula `a` is `Σ`-derivable iff it has a valid derivation from the axioms in `Σ`. -/
inductive derivable (axms : set formula) : formula → Prop
| k (a b : formula) : derivable (k a b)
| dual (a : formula) : derivable (dual a)
| taut (a : formula) (ha : tautology a) : derivable a
| axm (axm ∈ axms) (a : formula) (h : substitution_inst axm a) : derivable a
| mp (a b : formula) (hab : derivable (a ⟶ b)) (ha : derivable a) : derivable b
| nec {a : formula} (ha : derivable a) : derivable □a

reserve prefix `⊢ ` :15
reserve infix ` ⊢ ` :15

notation axms ⊢ a := derivable axms a
notation ⊢ a := ∅ ⊢ a

/-- A formula `a` is `Σ`-derivable from a set of premises `Γ` iff `Σ ⊢ C₁ → ⋯ → Cₙ → a` for some `{Cᵢ} ⊆ Γ`. -/
@[simp] def derivable.from (axms : set formula) (Γ : set formula) (a : formula) : Prop :=
∃xs, (∀x ∈ xs, x ∈ Γ) ∧ (axms ⊢ list.foldr formula.implies a xs)

notation Γ ` ⊢[`axms`] ` a := derivable.from axms Γ a

def derivable.from.rev {axms : set formula} (Γ : set formula) (Γ' : list formula) (a : formula) :
  (∀x ∈ Γ', x ∈ Γ) → (axms ⊢ Γ'.foldr formula.implies a) → (Γ ⊢[axms] a) :=
begin
  intros hΓ' hd,
  apply exists.intro Γ',
  tautology,
end

lemma all_antecedents {v : symbol → Prop} {mv : formula → Prop} (a : formula) (xs : list formula) :
  satisfies v mv (xs.foldr formula.implies a) ↔ (∀x ∈ xs, satisfies v mv x) → satisfies v mv a :=
begin
  apply iff.intro,
  { induction xs,
    { simp, },
    { intros ha hxs,
      simp at ha,
      apply xs_ih,
      { apply ha,
        apply hxs,
        simp, },
      { intros x hx,
        simp at hxs,
        apply hxs.elim_right,
        assumption, }, }, },
  { intro hxs,
    induction xs,
    { simp [hxs], },
    { simp,
      intro h,
      apply xs_ih,
      intros h,
      apply hxs,
      intros x hx,
      cases hx,
      { rw hx,
        assumption, },
      { apply h,
        exact hx, }, }, },
end

lemma derivable.redundant_premises {axms : set formula} {Γ : list formula} {a : formula} (Γ' ⊆ Γ) :
  (axms ⊢ Γ'.foldr formula.implies a) → (axms ⊢ Γ.foldr formula.implies a) :=
begin
  intro hΓ',
  apply derivable.mp (Γ'.foldr formula.implies a) _ _ hΓ',
  clear hΓ',
  derive_taut,
  intros v mv hΓ',
  rw all_antecedents at *,
  intro hΓ,
  apply hΓ',
  intros x hx,
  apply hΓ,
  apply H,
  assumption,
end

lemma derivable.from.exact {axms : set formula} (Γ : list formula) (a : formula) :
  (axms ⊢ Γ.foldr formula.implies a) ↔ ((λx, x ∈ Γ) ⊢[axms] a) :=
begin
  apply iff.intro,
  { intro h,
    apply derivable.from.rev (λx, x ∈ Γ) Γ,
    { tauto, },
    { assumption, }, },
  { intro h,
    cases h with xs hxs,
    cases hxs with hxs hd,
    have hxs' : xs ⊆ Γ := hxs,
    exact derivable.redundant_premises xs hxs hd, },
end

@[simp] lemma derivable.from.no_premises (axms : set formula) (a : formula) :
  (∅ ⊢[axms] a) ↔ (axms ⊢ a) :=
begin
  apply iff.intro,
  { intro h,
    cases h with xs hxs,
    cases hxs with hxs ha,
    cases xs,
    { simp [hxs] at ha,
      assumption, },
    { apply false.elim,
      apply hxs xs_hd,
      simp, }, },
  { intro h,
    apply exists.intro [],
    split,
    { tauto, },
    { exact h, }, },
end

lemma derivable.monotonicity {axms : set formula} (Γ Γ' : set formula) {a : formula} :
  Γ ⊆ Γ' → (Γ ⊢[axms] a) → (Γ' ⊢[axms] a) :=
begin
  intros hp hd,
  apply exists.elim hd,
  intros xs h,
  cases h,
  apply exists.intro xs,
  split,
  { intros x hx,
    apply hp,
    apply h_left x hx, },
  { assumption, }
end

lemma derivable.reflexivity {axms Γ : set formula} {a : formula} :
  a ∈ Γ → (Γ ⊢[axms] a) :=
begin
  intros ha,
  apply exists.intro [a],
  simp [ha],
  derive_taut,
end

lemma foldr_deduction (a b) (xs) :
  list.foldr formula.implies (b ⟶ a) xs = list.foldr formula.implies a (xs ++ [b]) :=
by simp

lemma derivable.deduction (axms : set formula) (Γ : set formula) (a b : formula) :
  (Γ ∪ {b} ⊢[axms] a) ↔ (Γ ⊢[axms] b ⟶ a) :=
begin
  apply iff.intro,
  { intro hda,
    cases hda with xs h,
    cases h with hxs hda,
    apply exists.intro (xs.filter (λx, x ≠ b)),
    split,
    { intros x hx,
      rw list.mem_filter at hx,
      have hx' : x ∈ xs := by simp [hx],
      apply or.elim (hxs x hx'),
      { tauto, },
      { intros hxb,
        apply not.elim (and.elim_right hx),
        cases hxb,
        refl, }, },
    { apply derivable.mp (xs.foldr formula.implies a) _ _ hda,
      derive_taut,
      intros v mv hsa,
      rw all_antecedents at *,
      intro h,
      simp,
      intro hsb,
      apply hsa,
      clear hsa,
      intros x hx,
      by_cases (x = b),
        { simp * at *, },
        { simp * at *, }, }, },
  { intro hdba,
    cases hdba,
    cases hdba_h,
    apply exists.intro (hdba_w ++ [b]),
    split,
    { intros x hx,
      simp at hx,
      cases hx,
      { apply or.intro_left,
        apply hdba_h_left x hx, },
      { apply or.intro_right,
        tauto, }, },
    { rw foldr_deduction at hdba_h_right,
      assumption, }, }
end

lemma mp_from_premises {v : symbol → Prop} {mv : formula → Prop} (a b : formula) (Γ : list formula)
    (hab : satisfies v mv (Γ.foldr formula.implies (a ⟶ b))) (ha : satisfies v mv (Γ.foldr formula.implies a)) :
  satisfies v mv (Γ.foldr formula.implies b) :=
begin
  induction Γ,
  { simp * at *, },
  { simp * at *,
    intro hhd,
    simp * at *, },
end

lemma derivable.from.mp {axms Γ : set formula} (a b : formula)
    (hab : Γ ⊢[axms] (a ⟶ b)) (ha : Γ ⊢[axms] a) :
  Γ ⊢[axms] b :=
begin
  cases hab with xs hxs,
  cases hxs with hxs hdab,
  cases ha with ys hys,
  cases hys with hys hda,
  apply exists.intro (xs ++ ys),
  split,
  { intros x hx,
    simp at hx,
    cases hx,
    { apply hxs, assumption, },
    { apply hys, assumption, }, },
  { apply derivable.mp (list.foldr formula.implies a (xs ++ ys)),
    { apply derivable.mp (list.foldr formula.implies (a ⟶ b) (xs ++ ys)),
      { derive_taut,
        intros v mv h₁ h₂,
        rw ←list.foldr_append at *,
        exact mp_from_premises a b (xs ++ ys) h₁ h₂, },
      { apply derivable.redundant_premises xs,
        { simp, },
        { assumption, } }, },
    { apply derivable.redundant_premises ys,
      { simp },
      { assumption }, }, },
end

lemma derivable.cut (axms : set formula) (Γ Γ' : set formula) (a b : formula) :
  (Γ ⊢[axms] a) → (Γ' ∪ {a} ⊢[axms] b) → (Γ ∪ Γ' ⊢[axms] b) :=
begin
  intros hda hdb,
  rw derivable.deduction at hdb,
  apply derivable.from.mp a b,
  { apply derivable.monotonicity Γ' _ _ hdb,
    simp, },
  { apply derivable.monotonicity Γ _ _ hda,
    simp, },
end

lemma derivable.from.box_not_iff_not_diamond {axms Γ : set formula} {a : formula} :
  (Γ ⊢[axms] □¬a) ↔ (Γ ⊢[axms] ¬◇a) :=
begin
  apply iff.intro,
  repeat {
    intro h,
    apply derivable.from.mp _ _ _ h,
    apply derivable.from.mp (dual a),
    { rw dual,
      derive_taut, },
    { ignore_premises,
      apply derivable.dual, },
  },
end

lemma derivable.from.not_box_iff_diamond_not {axms Γ : set formula} {a : formula} :
  (Γ ⊢[axms] ¬□a) ↔ (Γ ⊢[axms] ◇¬a) :=
begin
  apply iff.intro,
  { intro h,
    apply derivable.from.mp _ _ _ h,
    apply derivable.from.mp (dual ¬a),
    { rw dual,
      apply derivable.from.mp (¬□a ⟶ ¬□¬¬a),
      { derive_taut, },
      { apply derivable.from.mp (□¬¬a ⟶ □a),
        { derive_taut, },
        { ignore_premises,
          apply derivable.mp,
          { exact derivable.k (¬¬a) a, },
          { apply derivable.nec,
            derive_taut, }, }, }, },
    { ignore_premises,
      apply derivable.dual, }, },
  { intro h,
    apply derivable.from.mp _ _ _ h,
    apply derivable.from.mp (dual ¬a),
    { rw dual,
      apply derivable.from.mp (¬□¬¬a ⟶ ¬□a),
      { derive_taut, },
      { apply derivable.from.mp (□a ⟶ □¬¬a),
        { derive_taut, },
        { ignore_premises,
          apply derivable.mp,
          { apply derivable.k, },
          { apply derivable.nec,
            derive_taut, }, }, }, },
    { ignore_premises,
      apply derivable.dual, }, },
end

lemma derivable.RK {axms : set formula} {a : formula} {Γ : list formula} :
  (axms ⊢ Γ.foldr formula.implies a) → (axms ⊢ (Γ.map (λa, □a)).foldr formula.implies □a) :=
begin
  intro hda,
  induction Γ,
  { simp * at *,
    exact derivable.nec hda, },
  { sorry },
end

example (a b : formula) : ⊢ (a ∨ ¬a) ∧ (b ∨ ¬b) :=
by derive_taut

example (a b c : formula) : ⊢ (a ⟶ b) ⟶ (b ⟶ c) ⟶ (a ⟶ c) :=
by derive_taut

lemma box_and (a b : formula) : ⊢ □(a ∧ b) ⟶ (□a ∧ □b) :=
begin
  apply derivable.mp (□(a ∧ b) ⟶ □b),
  { apply derivable.mp (□(a ∧ b) ⟶ □a),
    { derive_taut, },
    { apply derivable.mp,
      { apply derivable.k (a ∧ b) a, },
      { apply derivable.nec,
        derive_taut, } } },
  { apply derivable.mp,
    { apply derivable.k, },
    { apply derivable.nec,
      derive_taut, } },
end


import .prop

set_option pp.parens true

open formula

def proof_equiv (P Q : formula) : Prop := is_proof (P.iff_ Q)

/--
is_repl_of_var_in_list u v l_u l_v = True if and only if l_v is the result of replacing one or more specified occurrences (but not necessarily all occurrences) of u in l_u by occurrences of v.
-/
def is_repl_of_var_in_list_fun (u v : variable_) : list variable_ → list variable_ → Prop
| [] [] := true
| (hd_u :: tl_u) (hd_v :: tl_v) := (hd_u = hd_v ∨ (hd_u = u ∧ hd_v = v)) ∧ is_repl_of_var_in_list_fun tl_u tl_v
| _ _ := false

/--
is_repl_of_var_in_formula_fun u v P_u P_v = True if and only if P_v is the result of replacing one or more specified occurrences (but not necessarily all occurrences) of u in P_u by occurrences of v.
-/
def is_repl_of_var_in_formula_fun (u v : variable_) : formula → formula → Prop
| true_ true_ := true
| (pred_ name_u args_u) (pred_ name_v args_v) := name_u = name_v ∧ is_repl_of_var_in_list_fun u v args_u args_v
| (eq_ x_u y_u) (eq_ x_v y_v) := (x_u = x_v ∨ (x_u = u ∧ x_v = v)) ∧ (y_u = y_v ∨ (y_u = u ∧ y_v = v))
| (not_ P_u) (not_ P_v) := is_repl_of_var_in_formula_fun P_u P_v
| (imp_ P_u Q_u) (imp_ P_v Q_v) := is_repl_of_var_in_formula_fun P_u P_v ∧ is_repl_of_var_in_formula_fun Q_u Q_v
| (forall_ x P_u) (forall_ x' P_v) := x = x' ∧ is_repl_of_var_in_formula_fun P_u P_v
| _ _ := false

/--
is_repl_of_var_in_formula u v P_u P_v = True if and only if P_v is the result of replacing one or more specified occurrences (but not necessarily all occurrences) of u in P_u by occurrences of v.
-/
inductive is_repl_of_var_in_formula (u v : variable_) : formula → formula → Prop
| true_ :
  is_repl_of_var_in_formula true_ true_

| pred_
  (name : pred_name_)
  (n : ℕ)
  (args_u args_v : fin n → variable_) :
  (∀ (i : fin n), (args_u i = args_v i) ∨ (args_u i = u ∧ args_v i = v)) →
  is_repl_of_var_in_formula (pred_ name (list.of_fn args_u)) (pred_ name (list.of_fn args_v))

| eq_
  (x_u y_u : variable_)
  (x_v y_v : variable_) :
  (x_u = x_v) ∨ (x_u = u ∧ x_v = v) →
  (y_u = y_v) ∨ (y_u = u ∧ y_v = v) →
  is_repl_of_var_in_formula (eq_ x_u y_u) (eq_ x_v y_v)

| not_
  (P_u P_v : formula) :
  is_repl_of_var_in_formula P_u P_v →
  is_repl_of_var_in_formula P_u.not_ P_v.not_

| imp_
  (P_u Q_u : formula)
  (P_v Q_v : formula) :
  is_repl_of_var_in_formula P_u P_v →
  is_repl_of_var_in_formula Q_u Q_v →
  is_repl_of_var_in_formula (P_u.imp_ Q_u) (P_v.imp_ Q_v)

| forall_
  (x : variable_)
  (P_u P_v : formula) :
  is_repl_of_var_in_formula P_u P_v →
  is_repl_of_var_in_formula (forall_ x P_u) (forall_ x P_v)

/--
is_repl_of_formula_in_formula_fun U V P_u P_v = True if and only if P_v is the result of replacing one or more specified occurrences (but not necessarily all occurrences) of U in P_u by occurrences of V.
-/
def is_repl_of_formula_in_formula_fun (U V : formula) : formula → formula → Prop
| (not_ P_u) (not_ P_v) := is_repl_of_formula_in_formula_fun P_u P_v
| (imp_ P_u Q_u) (imp_ P_v Q_v) := is_repl_of_formula_in_formula_fun P_u P_v ∧ is_repl_of_formula_in_formula_fun Q_u Q_v
| (forall_ x P_u) (forall_ x' P_v) := x = x' ∧ is_repl_of_formula_in_formula_fun P_u P_v
| P_u P_v := P_u = P_v ∨ (P_u = U ∧ P_v = V)

/--
is_repl_of_formula_in_formula U V P_u P_v = True if and only if P_v is the result of replacing one or more specified occurrences (but not necessarily all occurrences) of U in P_u by occurrences of V.
-/
inductive is_repl_of_formula_in_formula (U V : formula) : formula → formula → Prop
-- not replacing an occurrence
| same_
  (P_u P_v : formula) :
  P_u = P_v →
  is_repl_of_formula_in_formula P_u P_v

-- replacing an occurrence
| diff_
  (P_u P_v : formula) :
  P_u = U →
  P_v = V →
  is_repl_of_formula_in_formula P_u P_v

| not_
  (P_u P_v : formula) :
  is_repl_of_formula_in_formula P_u P_v →
  is_repl_of_formula_in_formula P_u.not_ P_v.not_

| imp_
  (P_u Q_u : formula)
  (P_v Q_v : formula) :
  is_repl_of_formula_in_formula P_u P_v →
  is_repl_of_formula_in_formula Q_u Q_v →
  is_repl_of_formula_in_formula (P_u.imp_ Q_u) (P_v.imp_ Q_v)

| forall_
  (x : variable_)
  (P_u P_v : formula) :
  is_repl_of_formula_in_formula P_u P_v →
  is_repl_of_formula_in_formula (forall_ x P_u) (forall_ x P_v)

def similar (P_u P_v : formula) (u v : variable_) : Prop :=
  ¬ is_free_in v P_u ∧
  ¬ is_free_in u P_v ∧
  fast_admits u v P_u ∧
  fast_admits v u P_v ∧
  P_v = fast_replace_free u v P_u ∧
  P_u = fast_replace_free v u P_v

-- Universal Elimination
theorem T_17_1
  (P : formula)
  (v t : variable_)
  (Δ : set formula)
  (h1 : is_deduct Δ (forall_ v P))
  (h2 : fast_admits v t P) :
  is_deduct Δ (fast_replace_free v t P) :=
begin
  apply is_deduct.mp_ (forall_ v P),
  {
    apply is_deduct.axiom_,
    apply is_axiom.pred_2_ v t P (fast_replace_free v t P) h2,
    refl,
  },
  {
    exact h1,
  }
end

alias T_17_1 <- spec forall_elim

lemma spec_id
  (v : variable_)
  (P : formula)
  (Δ : set formula)
  (h1 : is_deduct Δ (forall_ v P)) :
  is_deduct Δ P :=
begin
  apply is_deduct.mp_ (forall_ v P),
  {
    apply is_deduct.axiom_,
    apply is_axiom.pred_2_ v v P,
    {
      exact fast_admits_self P v,
    },
    {
      exact fast_replace_free_self P v,
    },
  },
  {
    exact h1,
  }
end

alias spec_id <- forall_elim_id

lemma SC_1
  (P Q : formula) :
  is_proof ((P.imp_ Q.not_).imp_ (Q.imp_ P.not_)) :=
begin
  apply prop_complete,
  unfold formula.is_tauto_atomic,
  simp only [eval_not, eval_imp],
  tauto,
end

theorem T_17_3
  (P : formula)
  (v t : variable_)
  (h1 : fast_admits v t P) :
  is_proof ((fast_replace_free v t P).imp_ (exists_ v P)) :=
begin
  unfold formula.exists_,
  unfold is_proof,
  apply is_deduct.mp_,
  {
    apply SC_1,
  },
  {
    unfold fast_admits at h1,

    apply is_deduct.axiom_,
    apply is_axiom.pred_2_ v t,
    {
      unfold fast_admits,
      unfold fast_admits_aux,
      exact h1,
    },
    {
      refl,
    },
  }
end

-- Existential Introduction
theorem T_17_4
  (P : formula)
  (v t : variable_)
  (Δ : set formula)
  (h1 : fast_admits v t P)
  (h2 : is_deduct Δ (fast_replace_free v t P)) :
  is_deduct Δ (exists_ v P) :=
begin
  apply is_deduct.mp_ (fast_replace_free v t P) (exists_ v P),
  {
    apply proof_imp_deduct,
    apply T_17_3,
    exact h1,
  },
  {
    exact h2,
  }
end

alias T_17_4 <- exists_intro

lemma exists_intro_id
  (P : formula)
  (v : variable_)
  (Δ : set formula)
  (h1 : is_deduct Δ P) :
  is_deduct Δ (exists_ v P) :=
begin
  apply T_17_4 P v v Δ,
  {
    exact fast_admits_self P v,
  },
  {
    simp only [fast_replace_free_self],
    exact h1,
  }
end

theorem T_17_6
  (P : formula)
  (v : variable_) :
  is_proof ((forall_ v P).imp_ (exists_ v P)) :=
begin
  apply deduction_theorem,
  simp only [set.union_singleton, insert_emptyc_eq],
  apply exists_intro_id,
  apply spec_id v,
  apply is_deduct.assume_,
  simp only [set.mem_singleton],
end

theorem T_17_7
  (Q : formula)
  (v : variable_)
  (Δ : set formula)
  (h1 : is_deduct Δ Q)
  (h2 : ∀ (H : formula), H ∈ Δ → ¬ is_free_in v H) :
  is_deduct Δ (forall_ v Q) :=
begin
  induction h1,
  case is_deduct.axiom_ : h1_P h1_1
  {
    apply is_deduct.axiom_,
    apply is_axiom.gen_,
    exact h1_1,
  },
  case is_deduct.assume_ : h1_P h1_1
  {
    apply is_deduct.mp_,
    {
      apply is_deduct.axiom_,
      apply is_axiom.pred_3_,
      exact h2 h1_P h1_1,
    },
    {
      apply is_deduct.assume_,
      exact h1_1,
    },
  },
  case is_deduct.mp_ : h1_P h1_Q h1_1 h1_2 h1_ih_1 h1_ih_2
  {
    apply is_deduct.mp_ (forall_ v h1_P),
    {
      apply is_deduct.mp_,
      {
        apply is_deduct.axiom_,
        apply is_axiom.pred_1_,
      },
      {
        exact h1_ih_1,
      }
    },
    {
      exact h1_ih_2,
    }
  },
end

alias T_17_7 <- generalization

-- Universal Introduction
example
  (P : formula)
  (v t : variable_)
  (Δ : set formula)
  (h1 : ¬ occurs_in t P)
  (h2 : is_deduct Δ (fast_replace_free v t P))
  (h3 : ∀ (H : formula), H ∈ Δ → ¬ is_free_in t H) :
  is_deduct Δ (forall_ v P) :=
begin
  apply is_deduct.mp_ (forall_ t (fast_replace_free v t P)),
  {
    apply proof_imp_deduct,
    apply deduction_theorem,
    simp only [set.union_singleton, insert_emptyc_eq],
    apply generalization,
    {
      have s1 : is_deduct {forall_ t (fast_replace_free v t P)} (fast_replace_free t v (fast_replace_free v t P)),
      apply spec,
      {
        apply is_deduct.assume_,
        simp only [set.mem_singleton],
      },
      {
        apply fast_replace_free_fast_admits,
        exact h1,
      },

      have s2 : (fast_replace_free t v (fast_replace_free v t P)) = P,
      exact fast_replace_free_inverse P v t h1,

      simp only [s2] at s1,
      exact s1,
    },
    {
      simp only [set.mem_singleton_iff, forall_eq],
      unfold is_free_in,
      simp only [not_and],
      intros a1 contra,
      exact not_is_free_in_fast_replace_free P v t a1 contra,
    }
  },
  {
    exact generalization (fast_replace_free v t P) t Δ h2 h3,
  },
end

example
  (P : formula)
  (h1 : is_proof_alt P) :
  is_deduct ∅ P :=
begin
  induction h1,
  case is_proof_alt.prop_true_ :
  {
    apply is_deduct.axiom_,
    apply is_axiom.prop_true_,
  },
  case is_proof_alt.prop_1_ : h1_P h1_Q
  {
    apply is_deduct.axiom_,
    apply is_axiom.prop_1_,
  },
  case is_proof_alt.prop_2_ : h1_P h1_Q h1_R
  {
    apply is_deduct.axiom_,
    apply is_axiom.prop_2_,
  },
  case is_proof_alt.prop_3_ : h1_P h1_Q
  {
    apply is_deduct.axiom_,
    apply is_axiom.prop_3_,
  },
  case is_proof_alt.pred_1_ : h1_v h1_P h1_Q
  {
    apply is_deduct.axiom_,
    apply is_axiom.pred_1_,
  },
  case is_proof_alt.pred_2_ : h1_v h1_t h1_P h1_P' h1_1 h1_ih_1
  {
    apply is_deduct.axiom_,
    exact is_axiom.pred_2_ h1_v h1_t h1_P h1_P' h1_1 h1_ih_1,
  },
  case is_proof_alt.pred_3_ : h1_v h1_P h1_1
  {
    apply is_deduct.axiom_,
    apply is_axiom.pred_3_,
    exact h1_1,
  },
  case is_proof_alt.eq_1_ : h1
  {
    apply is_deduct.axiom_,
    apply is_axiom.eq_1_,
  },
  case is_proof_alt.eq_2_pred_ : h1_name h1_n h1_xs h1_ys
  {
    apply is_deduct.axiom_,
    apply is_axiom.eq_2_pred_,
  },
  case is_proof_alt.eq_2_eq_ : h1_x_0 h1_y_0 h1_x_1 h1_y_1
  {
    apply is_deduct.axiom_,
    apply is_axiom.eq_2_eq_,
  },
  case is_proof_alt.gen_ : h1_v h1_P h1_1 h1_ih
  {
    apply generalization,
    {
      exact h1_ih,
    },
    {
      simp only [set.mem_empty_eq, is_empty.forall_iff, forall_const],
    }
  },
  case is_proof_alt.mp_ : h1_P h1_Q h1_1 h1_2 h1_ih_1 h1_ih_2
  {
    exact is_deduct.mp_ h1_P h1_Q h1_ih_1 h1_ih_2,
  },
end

example
  (P : formula)
  (h1 : is_deduct ∅ P) :
  is_proof_alt P :=
begin
  induction h1,
  case is_deduct.axiom_ : h1_P h1_1
  {
    induction h1_1,
    case is_axiom.prop_true_ :
    {
      apply is_proof_alt.prop_true_,
    },
    case is_axiom.prop_1_ : h1_1_P h1_1_Q
    {
      apply is_proof_alt.prop_1_,
    },
    case is_axiom.prop_2_ : h1_1_P h1_1_Q h1_1_R
    {
      apply is_proof_alt.prop_2_,
    },
    case is_axiom.prop_3_ : h1_1_P h1_1_Q
    {
      apply is_proof_alt.prop_3_,
    },
    case is_axiom.pred_1_ : h1_1_v h1_1_P h1_1_Q
    {
      apply is_proof_alt.pred_1_,
    },
    case is_axiom.pred_2_ : h1_1_v h1_1_t h1_1_P h1_1_1 h1_1_ih_1 h1_1_ih_2
    {
      apply is_proof_alt.pred_2_ h1_1_v h1_1_t h1_1_P h1_1_1 h1_1_ih_1 h1_1_ih_2,
    },
    case is_axiom.pred_3_ : h1_1_v h1_1_P h1_1_1
    {
      apply is_proof_alt.pred_3_,
      exact h1_1_1,
    },
    case is_axiom.eq_1_ : h1_1
    {
      apply is_proof_alt.eq_1_,
    },
    case is_axiom.eq_2_pred_ : h1_1_name h1_1_n h1_1_xs h1_1_ys
    {
      apply is_proof_alt.eq_2_pred_,
    },
    case is_axiom.eq_2_eq_ : h1_1_x_0 h1_1_y_0 h1_1_x_1 h1_1_y_1
    {
      apply is_proof_alt.eq_2_eq_,
    },
    case is_axiom.gen_ : h1_1_v h1_1_P h1_1_1 h1_1_ih
    {
      apply is_proof_alt.gen_,
      exact h1_1_ih,
    },
  },
  case is_deduct.assume_ : h1_P h1_1
  {
    simp only [set.mem_empty_eq] at h1_1,
    contradiction,
  },
  case is_deduct.mp_ : h1_P h1_Q h1_1 h1_2 h1_ih_1 h1_ih_2
  {
    exact is_proof_alt.mp_ h1_P h1_Q h1_ih_1 h1_ih_2,
  },
end

theorem T_17_10
  (P : formula)
  (u v : variable_) :
  is_proof ((forall_ u (forall_ v P)).imp_ (forall_ v (forall_ u P))) :=
begin
  apply deduction_theorem,
  simp only [set.union_singleton, insert_emptyc_eq],
  apply generalization,
  {
    apply generalization,
    {
      apply spec_id v P,
      apply spec_id u (forall_ v P),
      apply is_deduct.assume_,
      simp only [set.mem_singleton],
    },
    {
      simp only [set.mem_singleton_iff, forall_eq],
      unfold is_free_in,
      simp only [eq_self_iff_true, not_true, false_and, not_false_iff],
    }
  },
  {
    simp only [set.mem_singleton_iff, forall_eq],
    unfold is_free_in,
    simp only [eq_self_iff_true, not_true, false_and, and_false, not_false_iff],
  }
end

lemma SC_2
  (P Q R : formula)
  (Δ : set formula)
  (h1 : is_deduct Δ (Q.imp_ P))
  (h2 : is_deduct Δ (R.not_.imp_ Q)) :
  is_deduct Δ (P.not_.imp_ R) :=
begin
  apply is_deduct.mp_ (R.not_.imp_ Q),
  {
    apply is_deduct.mp_ (Q.imp_ P),
    {
      apply proof_imp_deduct,
      apply prop_complete,
      unfold formula.is_tauto_atomic,
      simp only [eval_imp, eval_not],
      tauto,
    },
    {
      exact h1,
    }
  },
  {
    exact h2,
  }
end

theorem T_17_11
  (P Q : formula)
  (v : variable_)
  (h1 : ¬ is_free_in v Q) :
  is_proof ((forall_ v (P.imp_ Q)).imp_ ((exists_ v P).imp_ Q)) :=
begin
  apply deduction_theorem,
  simp only [set.union_singleton, insert_emptyc_eq],
  unfold exists_,
  apply SC_2 (forall_ v P.not_) (forall_ v Q.not_) Q,
  {
    apply is_deduct.mp_,
    {
      apply is_deduct.axiom_,
      apply is_axiom.pred_1_,
    },
    {
      apply generalization,
      {
        apply is_deduct.mp_,
        {
          apply proof_imp_deduct,
          apply T_14_7,
        },
        {
          apply spec_id v (P.imp_ Q),
          apply is_deduct.assume_,
          simp only [set.mem_singleton],
        }
      },
      {
        simp only [set.mem_singleton_iff, forall_eq],
        unfold is_free_in,
        simp only [eq_self_iff_true, not_true, false_and, not_false_iff],
      }
    },
  },
  {
    apply is_deduct.axiom_,
    apply is_axiom.pred_3_,
    unfold is_free_in,
    exact h1,
  }
end

-- Rule C

theorem T_17_12
  (P Q : formula)
  (v : variable_)
  (Δ : set formula)
  (h1 : is_deduct Δ (exists_ v P))
  (h2 : is_deduct (Δ ∪ {P}) Q)
  (h3 : ∀ (H : formula), H ∈ Δ → ¬ is_free_in v H)
  (h4 : ¬ is_free_in v Q) :
  is_deduct Δ Q :=
begin
  apply is_deduct.mp_,
  {
    apply is_deduct.mp_,
    {
      apply proof_imp_deduct,
      exact T_17_11 P Q v h4,
    },
    {
      apply generalization,
      {
        apply deduction_theorem,
        exact h2,
      },
      {
        exact h3,
      }
    },
  },
  {
    exact h1,
  }
end

alias T_17_12 <- rule_C

example
  (P Q : formula)
  (v t : variable_)
  (Δ : set formula)
  (h1 : is_deduct Δ (exists_ v P))
  (h2 : is_deduct (Δ ∪ {replace_free v t P}) Q)
  (h3 : ¬ occurs_in t P)
  (h4 : ¬ occurs_in t Q)
  (h5 : ∀ (H : formula), H ∈ Δ → ¬ is_free_in t H) :
  is_deduct Δ Q :=
begin
  sorry,
--  apply rule_C (replace_free v t P) Q t Δ,
end

lemma and_intro
  (P Q : formula)
  (Δ : set formula) :
  is_deduct Δ (P.imp_ (Q.imp_ (P.and_ Q))) :=
begin
  unfold formula.and_,
  apply proof_imp_deduct,
  apply prop_complete,
  unfold formula.is_tauto_atomic,
  simp only [eval_not, eval_imp],
  tauto,
end

lemma and_elim_left
  (P Q : formula)
  (Δ : set formula) :
  is_deduct Δ ((P.and_ Q).imp_ P) :=
begin
  unfold formula.and_,
  apply proof_imp_deduct,
  apply prop_complete,
  unfold formula.is_tauto_atomic,
  simp only [eval_not, eval_imp],
  tauto,
end

lemma and_elim_right
  (P Q : formula)
  (Δ : set formula) :
  is_deduct Δ ((P.and_ Q).imp_ Q) :=
begin
  unfold formula.and_,
  apply proof_imp_deduct,
  apply prop_complete,
  unfold formula.is_tauto_atomic,
  simp only [eval_not, eval_imp],
  tauto,
end

theorem T_17_14
  (P Q : formula)
  (v : variable_) :
  is_proof ((exists_ v (P.and_ Q)).imp_ ((exists_ v P).and_ (exists_ v Q))) :=
begin
  apply deduction_theorem,
  simp only [set.union_singleton, insert_emptyc_eq],
  apply rule_C (P.and_ Q) ((exists_ v P).and_ (exists_ v Q)) v,
  {
    apply is_deduct.assume_,
    simp only [set.mem_singleton],
  },
  {
    apply is_deduct.mp_ (exists_ v Q),
    {
      apply is_deduct.mp_ (exists_ v P),
      {
        apply deduction_theorem,
        apply deduction_theorem,
        apply is_deduct.mp_,
        {
          apply is_deduct.mp_,
          {
            apply and_intro,
          },
          {
            apply is_deduct.assume_,
            simp only [set.union_singleton, set.mem_insert_iff, eq_self_iff_true, true_or, or_true],
          }
        },
        {
          apply is_deduct.assume_,
          simp only [set.union_singleton, set.mem_insert_iff, eq_self_iff_true, true_or],
        }
      },
      {
        apply exists_intro P v v,
        {
          apply fast_admits_self,
        },
        {
          simp only [fast_replace_free_self],
          apply is_deduct.mp_,
          {
            apply and_elim_left P Q,
          },
          {
            apply is_deduct.assume_,
            simp only [set.union_singleton, set.mem_insert_iff, eq_self_iff_true, true_or],
          }
        },
      }
    },
    {
      apply exists_intro Q v v,
      {
        apply fast_admits_self,
      },
      {
        simp only [fast_replace_free_self],
        apply is_deduct.mp_,
        {
          apply and_elim_right P Q,
        },
        {
          apply is_deduct.assume_,
          simp only [set.union_singleton, set.mem_insert_iff, eq_self_iff_true, true_or],
        }
      }
    }
  },
  {
    unfold and_,
    unfold exists_,
    simp only [set.mem_singleton_iff, forall_eq],
    unfold is_free_in,
    simp only [eq_self_iff_true, not_true, false_and, not_false_iff],
  },
  {
    unfold and_,
    unfold exists_,
    unfold is_free_in,
    simp only [eq_self_iff_true, not_true, false_and, or_self, not_false_iff],
  }
end

theorem T_18_1_left
  (P Q : formula)
  (v : variable_) :
  is_proof ((forall_ v (P.iff_ Q)).imp_ ((forall_ v P).imp_ (forall_ v Q))) :=
begin
  unfold iff_,
  apply deduction_theorem,
  apply deduction_theorem,
  simp only [set.union_singleton, insert_emptyc_eq],
  apply generalization,
  {
    apply is_deduct.mp_ P,
    {
      apply is_deduct.mp_ ((P.imp_ Q).and_ (Q.imp_ P)),
      {
        apply and_elim_left,
      },
      {
        apply spec_id v ((P.imp_ Q).and_ (Q.imp_ P)),
        apply is_deduct.assume_,
        simp only [set.mem_insert_iff, set.mem_singleton, or_true],
      }
    },
    {
      apply spec_id v P,
      apply is_deduct.assume_,
      simp only [set.mem_insert_iff, eq_self_iff_true, true_and, true_or],
    }
  },
  {
    simp only [set.mem_insert_iff, set.mem_singleton_iff, forall_eq_or_imp, forall_eq],
    unfold is_free_in,
    simp only [eq_self_iff_true, not_true, false_and, not_false_iff, and_self],
  }
end

theorem T_18_1_right
  (P Q : formula)
  (v : variable_) :
  is_proof ((forall_ v (P.iff_ Q)).imp_ ((forall_ v Q).imp_ (forall_ v P))) :=
begin
  unfold iff_,
  apply deduction_theorem,
  apply deduction_theorem,
  simp only [set.union_singleton, insert_emptyc_eq],
  apply generalization,
  {
    apply is_deduct.mp_ Q,
    {
      apply is_deduct.mp_ ((P.imp_ Q).and_ (Q.imp_ P)),
      {
        apply and_elim_right,
      },
      {
        apply spec_id v ((P.imp_ Q).and_ (Q.imp_ P)),
        apply is_deduct.assume_,
        simp only [set.mem_insert_iff, set.mem_singleton, or_true],
      }
    },
    {
      apply spec_id v Q,
      apply is_deduct.assume_,
      simp only [set.mem_insert_iff, eq_self_iff_true, true_and, true_or],
    }
  },
  {
    simp only [set.mem_insert_iff, set.mem_singleton_iff, forall_eq_or_imp, forall_eq],
    unfold is_free_in,
    simp only [eq_self_iff_true, not_true, false_and, not_false_iff, and_self],
  }
end

theorem T_18_1
  (P Q : formula)
  (v : variable_) :
  is_proof ((forall_ v (P.iff_ Q)).imp_ ((forall_ v P).iff_ (forall_ v Q))) :=
begin
  apply is_deduct.mp_ ((forall_ v (P.iff_ Q)).imp_ ((forall_ v Q).imp_ (forall_ v P))),
  {
    apply is_deduct.mp_ ((forall_ v (P.iff_ Q)).imp_ ((forall_ v P).imp_ (forall_ v Q))),
    {
      unfold formula.iff_,
      unfold formula.and_,
      apply prop_complete,
      unfold formula.is_tauto_atomic,
      simp only [eval_not, eval_imp],
      tauto,
    },
    {
      apply T_18_1_left,
    }
  },
  {
    apply T_18_1_right,
  }
end

lemma Forall_spec_id
  (xs : list variable_)
  (P : formula) :
  is_proof ((Forall_ xs P).imp_ P) :=
begin
  induction xs,
  case list.nil
  {
    unfold Forall_,
    apply prop_id,
  },
  case list.cons : xs_hd xs_tl xs_ih
  {
    unfold Forall_,
    apply deduction_theorem,
    simp only [list.foldr_cons, set.union_singleton, insert_emptyc_eq],
    apply is_deduct.mp_ (Forall_ xs_tl P),
    apply proof_imp_deduct,
    exact xs_ih,
    apply spec_id xs_hd,
    apply is_deduct.assume_,
    simp only [set.mem_singleton_iff, eq_self_iff_true, true_and],
    refl,
  },
end

lemma Forall_spec_id'
  (xs : list variable_)
  (P : formula)
  (Δ : set formula)
  (h1 : is_deduct Δ (Forall_ xs P)) :
  is_deduct Δ P :=
begin
  induction xs,
  case list.nil
  {
    unfold Forall_ at h1,
    simp only [list.foldr_nil] at h1,
    exact h1,
  },
  case list.cons : xs_hd xs_tl xs_ih
  {
    unfold Forall_ at h1,
    simp only [list.foldr_cons] at h1,

    apply xs_ih,
    unfold Forall_,
    apply spec_id xs_hd,
    exact h1,
  },
end

lemma prop_iff_id
  (P : formula) :
  is_proof (P.iff_ P) :=
begin
  unfold formula.iff_,
  unfold formula.and_,
  apply prop_complete,
  unfold formula.is_tauto_atomic,
  simp only [eval_not, eval_imp],
  simp only [imp_self, not_true, not_false_iff, forall_const],
end

lemma Forall_is_bound_in
  (P : formula)
  (xs : list variable_)
  (x : variable_) :
  is_bound_in x (Forall_ xs P) ↔ (x ∈ xs ∨ is_bound_in x P) :=
begin
  unfold formula.Forall_,

  induction xs,
  case list.nil
  {
    simp only [list.foldr_nil, list.not_mem_nil, false_or],
  },
  case list.cons : xs_hd xs_tl xs_ih
  {
    simp only [list.foldr_cons, list.mem_cons_iff],
    unfold is_bound_in,
    simp only [xs_ih],
    tauto,
  },
end

lemma Forall_is_free_in
  (P : formula)
  (xs : list variable_)
  (x : variable_) :
  is_free_in x (Forall_ xs P) ↔ (x ∉ xs ∧ is_free_in x P) :=
begin
  unfold formula.Forall_,

  induction xs,
  case list.nil
  {
    simp only [list.foldr_nil, list.not_mem_nil, not_false_iff, true_and],
  },
  case list.cons : xs_hd xs_tl xs_ih
  {
    simp only [list.foldr_cons, list.mem_cons_iff],
    unfold is_free_in,
    simp only [xs_ih],
    tauto,
  },
end

-- The equivalence theorem
theorem T_18_2
  (U V : formula)
  (P_U P_V : formula)
  (l : list variable_)
  (h1 : is_repl_of_formula_in_formula U V P_U P_V)
  (h2 : ∀ (v : variable_), ((is_free_in v U ∨ is_free_in v V) ∧ is_bound_in v P_U) → v ∈ l) :
  is_proof ((Forall_ l (U.iff_ V)).imp_ (P_U.iff_ P_V)) :=
begin
  induction h1,
  case is_repl_of_formula_in_formula.same_ : h1_P h1_P' h1_1
  {
    subst h1_1,
    apply deduction_theorem,
    apply proof_imp_deduct,
    apply prop_iff_id,
  },
  case is_repl_of_formula_in_formula.diff_ : h1_P h1_P' h1_1 h1_2
  {
    subst h1_1,
    subst h1_2,
    apply Forall_spec_id,
  },
  case is_repl_of_formula_in_formula.not_ : h1_P h1_P' h1_1 h1_ih
  {
    unfold is_bound_in at h2,

    apply is_deduct.mp_ ((Forall_ l (U.iff_ V)).imp_ (h1_P.iff_ h1_P')),
    {
      unfold formula.iff_,
      unfold formula.and_,
      apply prop_complete,
      unfold formula.is_tauto_atomic,
      simp only [eval_not, eval_imp],
      tauto,
    },
    {
      exact h1_ih h2,
    },
  },
  case is_repl_of_formula_in_formula.imp_ : h1_P h1_Q h1_P' h1_Q' h1_1 h1_2 h1_ih_1 h1_ih_2
  {
    unfold is_bound_in at h2,

    apply is_deduct.mp_ ((Forall_ l (U.iff_ V)).imp_ (h1_P.iff_ h1_P')),
    {
      apply is_deduct.mp_ ((Forall_ l (U.iff_ V)).imp_ (h1_Q.iff_ h1_Q')),
      {
        unfold formula.iff_,
        unfold formula.and_,
        apply prop_complete,
        unfold formula.is_tauto_atomic,
        simp only [eval_not, eval_imp],
        tauto,
      },
      {
        apply h1_ih_2,
        intros v a2,
        apply h2 v,
        tauto,
      }
    },
    {
      apply h1_ih_1,
      intros v a1,
      apply h2 v,
      tauto,
    },
  },
  case is_repl_of_formula_in_formula.forall_ : h1_x h1_P h1_P' h1_1 h1_ih
  {
    unfold is_bound_in at h2,

    apply deduction_theorem,
    simp only [set.union_singleton, insert_emptyc_eq],
    apply is_deduct.mp_ (forall_ h1_x (h1_P.iff_ h1_P')),
    {
      apply proof_imp_deduct,
      apply T_18_1,
    },
    {
      apply generalization,
      {
        apply is_deduct.mp_ (Forall_ l (U.iff_ V)),
        {
          apply proof_imp_deduct,
          apply h1_ih,
          intros v a1,
          cases a1,
          apply h2 v,
          tauto,
        },
        {
          apply is_deduct.assume_,
          simp only [set.mem_singleton],
        }
      },
      {
        intros H a1,
        simp only [set.mem_singleton_iff] at a1,
        subst a1,
        simp only [Forall_is_free_in],
        unfold formula.iff_,
        unfold formula.and_,
        unfold is_free_in,
        simp only [not_and],
        contrapose,
        push_neg,
        intros a2,
        apply h2,
        tauto,
      }
    }
  },
end

theorem C_18_3
  (U V : formula)
  (P_U P_V : formula)
  (h1 : is_repl_of_formula_in_formula U V P_U P_V)
  (h2 : is_proof (U.iff_ V)) :
  is_proof (P_U.iff_ P_V) :=
begin
  apply is_deduct.mp_,
  {
    apply T_18_2 U V P_U P_V ((U.free_var_set ∪ V.free_var_set) ∩ P_U.bound_var_set).to_list h1,
    intros v a1,
    simp only [finset.mem_to_list, finset.mem_inter, finset.mem_union],
    simp only [is_free_in_iff_mem_free_var_set, is_bound_in_iff_mem_bound_var_set] at a1,
    exact a1,
  },
  {
    unfold formula.Forall_,
    induction ((U.free_var_set ∪ V.free_var_set) ∩ P_U.bound_var_set).to_list,
    case list.nil
    {
      simp only [list.foldr_nil],
      exact h2,
    },
    case list.cons : hd tl ih
    {
      simp only [list.foldr_cons],
      apply generalization,
      {
        exact ih,
      },
      {
        simp only [set.mem_empty_eq, is_empty.forall_iff, forall_const],
      }
    },
  }
end

-- The replacement theorem
theorem C_18_4
  (U V : formula)
  (P_U P_V : formula)
  (Δ : set formula)
  (h1 : is_repl_of_formula_in_formula U V P_U P_V)
  (h2 : is_proof (U.iff_ V))
  (h3 : is_deduct Δ P_U) :
  is_deduct Δ P_V :=
begin
  apply is_deduct.mp_ P_U,
  {
    apply is_deduct.mp_ (P_U.iff_ P_V),
    {
      unfold formula.iff_,
      unfold formula.and_,
      apply proof_imp_deduct,
      apply prop_complete,
      unfold formula.is_tauto_atomic,
      simp only [eval_not, eval_imp],
      tauto,
    },
    {
      apply proof_imp_deduct,
      exact C_18_3 U V P_U P_V h1 h2,
    }
  },
  {
    exact h3,
  }
end

theorem T_18_6
  (P_u P_v : formula)
  (u v : variable_)
  (h1 : similar P_u P_v u v) :
  is_proof ((forall_ u P_u).iff_ (forall_ v P_v)) :=
begin
  unfold similar at h1;
  cases h1, cases h1_right, cases h1_right_right, cases h1_right_right_right, cases h1_right_right_right_right,

  have s1 : is_proof ((forall_ u P_u).imp_ (forall_ v P_v)),
  apply deduction_theorem,
  simp only [set.union_singleton, insert_emptyc_eq],
  apply generalization,
  {
    subst h1_right_right_right_right_left,
    apply spec,
    {
      apply is_deduct.assume_,
      simp only [set.mem_singleton],
    },
    {
      exact h1_right_right_left,
    }
  },
  {
    intros H a1,
    simp only [set.mem_singleton_iff] at a1,
    subst a1,
    unfold is_free_in,
    simp only [not_and],
    intros a2,
    exact h1_left,
  },

  have s2 : is_proof ((forall_ v P_v).imp_ (forall_ u P_u)),
  apply deduction_theorem,
  simp only [set.union_singleton, insert_emptyc_eq],
  apply generalization,
  {
    subst h1_right_right_right_right_right,
    apply spec,
    {
      apply is_deduct.assume_,
      simp only [set.mem_singleton],
    },
    {
      exact h1_right_right_right_left,
    }
  },
  {
    intros H a1,
    simp only [set.mem_singleton_iff] at a1,
    subst a1,
    unfold is_free_in,
    simp only [not_and],
    intros a2,
    exact h1_right_left,
  },

  apply is_deduct.mp_ ((forall_ v P_v).imp_ (forall_ u P_u)),
  {
    apply is_deduct.mp_ ((forall_ u P_u).imp_ (forall_ v P_v)),
    {
      unfold formula.iff_,
      unfold formula.and_,
      apply proof_imp_deduct,
      apply prop_complete,
      unfold formula.is_tauto_atomic,
      simp only [eval_not, eval_imp],
      tauto,
    },
    {
      exact s1,
    }
  },
  {
    exact s2,
  }
end

-- Change of bound variable
theorem T_18_7
  (P_u P_v Q Q' : formula)
  (u v : variable_)
  (Δ : set formula)
  (h1 : is_deduct Δ Q)
  (h2 : is_repl_of_formula_in_formula (forall_ u P_u) (forall_ v P_v) Q Q')
  (h3 : similar P_u P_v u v) :
  is_deduct Δ Q' :=
begin
  apply C_18_4 (forall_ u P_u) (forall_ v P_v) Q Q' Δ h2,
  {
    apply T_18_6 P_u P_v u v h3,
  },
  {
    exact h1,
  }
end

theorem T_19_1
  (P : formula)
  (v : variable_)
  (h1 : ¬ is_free_in v P) :
  is_proof ((forall_ v P).iff_ P) :=
begin
  apply is_deduct.mp_ ((forall_ v P).imp_ P),
  {
    apply is_deduct.mp_ (P.imp_ (forall_ v P)),
    {
      unfold formula.iff_,
      unfold formula.and_,
      apply proof_imp_deduct,
      apply prop_complete,
      unfold formula.is_tauto_atomic,
      simp only [eval_not, eval_imp],
      tauto,
    },
    {
      apply is_deduct.axiom_,
      exact is_axiom.pred_3_ v P h1,
    },
  },
  {
    apply is_deduct.axiom_,
    apply is_axiom.pred_2_ v v P P,
    {
      apply fast_admits_self,
    },
    {
      apply fast_replace_free_self,
    }
  },
end

theorem T_19_2
  (P : formula)
  (u v : variable_) :
  is_proof ((forall_ u (forall_ v P)).iff_ ((forall_ v (forall_ u P)))) :=
begin
  apply is_deduct.mp_ ((forall_ u (forall_ v P)).imp_ ((forall_ v (forall_ u P)))),
  {
    apply is_deduct.mp_ ((forall_ v (forall_ u P)).imp_ ((forall_ u (forall_ v P)))),
    {
      unfold formula.iff_,
      unfold formula.and_,
      apply proof_imp_deduct,
      apply prop_complete,
      unfold formula.is_tauto_atomic,
      simp only [eval_not, eval_imp],
      tauto,
    },
    {
      apply T_17_10,
    },
  },
  {
    apply T_17_10,
  },
end

theorem T_19_TS_21_left
  (P Q : formula)
  (v : variable_)
  (h1 : ¬ is_free_in v P) :
  is_proof ((forall_ v (P.imp_ Q)).imp_ (P.imp_ (forall_ v Q))) :=
begin
  apply C_18_4 (forall_ v P) P ((forall_ v (P.imp_ Q)).imp_ ((forall_ v P).imp_ (forall_ v Q))),
  {
    apply is_repl_of_formula_in_formula.imp_,
    {
      apply is_repl_of_formula_in_formula.same_,
      refl,
    },
    {
      apply is_repl_of_formula_in_formula.imp_,
      {
        apply is_repl_of_formula_in_formula.diff_,
        {
          refl,
        },
        {
          refl,
        },
      },
      {
        apply is_repl_of_formula_in_formula.same_,
        refl,
      },
    }
  },
  {
    exact T_19_1 P v h1,
  },
  {
    apply is_deduct.axiom_,
    apply is_axiom.pred_1_,
  },
end

theorem T_19_TS_21_right
  (P Q : formula)
  (v : variable_)
  (h1 : ¬ is_free_in v P) :
  is_proof ((P.imp_ (forall_ v Q)).imp_ (forall_ v (P.imp_ Q))) :=
begin
  apply deduction_theorem,
  simp only [set.union_singleton, insert_emptyc_eq],
  apply generalization,
  {
    apply deduction_theorem,
    apply spec_id v,
    apply is_deduct.mp_ P,
    {
      apply is_deduct.assume_,
      simp only [set.union_singleton, set.mem_insert_iff, set.mem_singleton, or_true],
    },
    {
      apply is_deduct.assume_,
      simp only [set.union_singleton, set.mem_insert_iff, eq_self_iff_true, true_or],
    },
  },
  {
    intros H a1,
    simp only [set.mem_singleton_iff] at a1,
    subst a1,
    unfold is_free_in,
    push_neg,
    split,
    {
      exact h1,
    },
    {
      intros a1,
      contradiction,
    }
  },
end

theorem T_19_TS_21
  (P Q : formula)
  (v : variable_)
  (h1 : ¬ is_free_in v P) :
  is_proof ((forall_ v (P.imp_ Q)).iff_ (P.imp_ (forall_ v Q))) :=
begin
  apply is_deduct.mp_ ((forall_ v (P.imp_ Q)).imp_ (P.imp_ (forall_ v Q))),
  {
    apply is_deduct.mp_ ((P.imp_ (forall_ v Q)).imp_ (forall_ v (P.imp_ Q))),
    {
      unfold formula.iff_,
      unfold formula.and_,
      apply proof_imp_deduct,
      apply prop_complete,
      unfold formula.is_tauto_atomic,
      simp only [eval_not, eval_imp],
      tauto,
    },
    {
      exact T_19_TS_21_right P Q v h1,
    },
  },
  {
    exact T_19_TS_21_left P Q v h1,
  },
end

theorem T_21_1
  (x y : variable_) :
  is_proof (forall_ x (forall_ y ((eq_ x y).imp_ (eq_ y x)))) :=
begin
  apply generalization,
  {
    apply generalization,
    {
      apply is_deduct.mp_ (eq_ y y),
      {
        apply is_deduct.mp_ (((eq_ y y).and_ (eq_ x y)).imp_ ((eq_ y x).iff_ (eq_ y y))),
        {
          unfold formula.iff_,
          unfold formula.and_,
          apply proof_imp_deduct,
          apply prop_complete,
          unfold formula.is_tauto_atomic,
          simp only [eval_not, eval_imp],
          tauto,
        },
        {
          apply spec_id y,
          apply spec_id y,
          apply spec_id x,
          apply spec_id y,
          apply is_deduct.axiom_,
          exact is_axiom.eq_2_eq_ y x y y,
        }
      },
      {
        apply spec_id y,
        apply is_deduct.axiom_,
        exact is_axiom.eq_1_ y,
      }
    },
    {
      intros H a1,
      simp only [set.mem_empty_eq] at a1,
      contradiction,
    }
  },
  {
    intros H a1,
    simp only [set.mem_empty_eq] at a1,
    contradiction,
  }
end

theorem T_21_2
  (x y z : variable_) :
  is_proof (forall_ x (forall_ y (forall_ z (((eq_ x y).and_ (eq_ y z)).imp_ (eq_ x z))))) :=
begin
  apply generalization,
  {
    apply generalization,
    {
      apply generalization,
      {
        apply is_deduct.mp_ (eq_ z z),
        {
          apply is_deduct.mp_ (((eq_ x y).and_ (eq_ z z)).imp_ ((eq_ x z).iff_ (eq_ y z))),
          {
            unfold formula.iff_,
            unfold formula.and_,
            apply proof_imp_deduct,
            apply prop_complete,
            unfold formula.is_tauto_atomic,
            simp only [eval_not, eval_imp],
            tauto,
          },
          {
            apply spec_id z,
            apply spec_id y,
            apply spec_id z,
            apply spec_id x,
            apply is_deduct.axiom_,
            exact is_axiom.eq_2_eq_ x z y z,
          },
        },
        {
          apply spec_id z,
          apply is_deduct.axiom_,
          exact is_axiom.eq_1_ z,
        }
      },
      {
        intros H a1,
        simp only [set.mem_empty_eq] at a1,
        contradiction,
      },
    },
    {
      intros H a1,
      simp only [set.mem_empty_eq] at a1,
      contradiction,
    },
  },
  {
    intros H a1,
    simp only [set.mem_empty_eq] at a1,
    contradiction,
  },
end

theorem T_21_8
  (P_r P_s : formula)
  (r s : variable_)
  (h1 : is_repl_of_var_in_formula r s P_r P_s)
  (h2 : ¬ is_bound_in r P_r)
  (h3 : ¬ is_bound_in s P_r) :
  is_proof ((eq_ r s).imp_ (P_r.iff_ P_s)) :=
begin
  induction h1,
  case is_repl_of_var_in_formula.true_
  {
    unfold formula.iff_,
    unfold formula.and_,
    apply proof_imp_deduct,
    apply prop_complete,
    unfold formula.is_tauto_atomic,
    simp only [eval_not, eval_imp],
    tauto,
  },
  case is_repl_of_var_in_formula.pred_ : name n args_u args_v h1_1
  {
    apply deduction_theorem,
    simp only [set.union_singleton, insert_emptyc_eq],
    apply is_deduct.mp_ ((pred_ name (list.of_fn args_u)).iff_ (pred_ name (list.of_fn args_v))),
    {
      apply proof_imp_deduct,
      apply prop_complete,
      unfold formula.is_tauto_atomic,
      simp only [eval_not, eval_imp],
      tauto,
    },
    {
      apply is_deduct.mp_ (And_ (list.of_fn (λ (i : fin n), eq_ (args_u i) (args_v i)))),
      {
        apply Forall_spec_id' (list.of_fn args_v),
        apply Forall_spec_id' (list.of_fn args_u),
        apply is_deduct.axiom_,
        exact is_axiom.eq_2_pred_ name n args_u args_v,
      },
      {
        clear h2,
        clear h3,
        induction n,
        case nat.zero
        {
          simp only [list.of_fn_zero],
          apply is_deduct.axiom_,
          apply is_axiom.prop_true_,
        },
        case nat.succ : n ih
        {
          unfold And_ at ih,

          unfold And_,
          simp only [list.of_fn_succ, list.foldr_cons],
          apply is_deduct.mp_ (list.foldr and_ true_ (list.of_fn (λ (i : fin n), eq_ (args_u i.succ) (args_v i.succ)))),
          {
            apply is_deduct.mp_ (eq_ (args_u 0) (args_v 0)),
            {
              unfold formula.and_,
              apply proof_imp_deduct,
              apply prop_complete,
              unfold formula.is_tauto_atomic,
              simp only [eval_not, eval_imp],
              tauto,
            },
            {
              specialize h1_1 0,
              cases h1_1,
              {
                rewrite h1_1,
                apply spec_id (args_v 0),
                apply is_deduct.axiom_,
                apply is_axiom.eq_1_,
              },
              {
                cases h1_1,
                subst h1_1_left,
                subst h1_1_right,
                apply is_deduct.assume_,
                simp only [set.mem_singleton],
              }
            }
          },
          {
            apply ih,
            intros i,
            apply h1_1,
          },
        },
      },
    },
  },
  case is_repl_of_var_in_formula.eq_ : x_u y_u x_v y_v h1_1 h1_2
  {
    apply is_deduct.mp_ (((eq_ x_u x_v).and_ (eq_ y_u y_v)).imp_ ((eq_ x_u y_u).iff_ (eq_ x_v y_v))),
    {
      apply is_deduct.mp_ ((eq_ r s).imp_ ((eq_ x_u x_v).and_ (eq_ y_u y_v))),
      {
        unfold formula.iff_,
        unfold formula.and_,
        apply proof_imp_deduct,
        apply prop_complete,
        unfold formula.is_tauto_atomic,
        simp only [eval_not, eval_imp],
        tauto,
      },
      {
        cases h1_1,
        {
          subst h1_1,
          cases h1_2,
          {
            subst h1_2,
            apply is_deduct.mp_ (eq_ x_u x_u),
            {
              apply is_deduct.mp_ (eq_ y_u y_u),
              {
                unfold formula.and_,
                apply proof_imp_deduct,
                apply prop_complete,
                unfold formula.is_tauto_atomic,
                simp only [eval_not, eval_imp],
                tauto,
              },
              {
                apply spec_id y_u,
                apply is_deduct.axiom_,
                exact is_axiom.eq_1_ y_u,
              }
            },
            {
              apply spec_id x_u,
              apply is_deduct.axiom_,
              exact is_axiom.eq_1_ x_u,
            }
          },
          {
            cases h1_2,
            subst h1_2_left,
            subst h1_2_right,
            apply is_deduct.mp_ (eq_ x_u x_u),
            {
              unfold formula.and_,
              apply proof_imp_deduct,
              apply prop_complete,
              unfold formula.is_tauto_atomic,
              simp only [eval_not, eval_imp],
              tauto,
            },
            {
              apply spec_id x_u,
              apply is_deduct.axiom_,
              exact is_axiom.eq_1_ x_u,
            }
          }
        },
        {
          cases h1_1,
          subst h1_1_left,
          subst h1_1_right,
          cases h1_2,
          {
            subst h1_2,
            apply is_deduct.mp_ (eq_ y_u y_u),
            {
              unfold formula.and_,
              apply proof_imp_deduct,
              apply prop_complete,
              unfold formula.is_tauto_atomic,
              simp only [eval_not, eval_imp],
              tauto,
            },
            {
              apply spec_id y_u,
              apply is_deduct.axiom_,
              exact is_axiom.eq_1_ y_u,
            }
          },
          {
            cases h1_2,
            subst h1_2_left,
            subst h1_2_right,

            unfold formula.and_,
            apply proof_imp_deduct,
            apply prop_complete,
            unfold formula.is_tauto_atomic,
            simp only [eval_not, eval_imp],
            tauto,
          }
        },
      }
    },
    {
      apply spec_id y_v,
      apply spec_id x_v,
      apply spec_id y_u,
      apply spec_id x_u,
      apply is_deduct.axiom_,
      exact is_axiom.eq_2_eq_ x_u y_u x_v y_v,
    }
  },
  case is_repl_of_var_in_formula.not_ : P_u P_v h1_1 h1_ih
  {
    unfold is_bound_in at h2,

    unfold is_bound_in at h3,

    specialize h1_ih h2 h3,
    apply is_deduct.mp_ ((eq_ r s).imp_ (P_u.iff_ P_v)),
    {
      unfold formula.iff_,
      unfold formula.and_,
      apply proof_imp_deduct,
      apply prop_complete,
      unfold formula.is_tauto_atomic,
      simp only [eval_not, eval_imp],
      tauto,
    },
    {
      exact h1_ih,
    }
  },
  case is_repl_of_var_in_formula.imp_ : P_u Q_u P_v Q_v h1_1 h1_2 h1_ih_1 h1_ih_2
  {
    unfold is_bound_in at h2,
    push_neg at h2,
    cases h2,

    unfold is_bound_in at h3,
    push_neg at h3,
    cases h3,

    specialize h1_ih_1 h2_left h3_left,
    specialize h1_ih_2 h2_right h3_right,
    apply is_deduct.mp_ ((eq_ r s).imp_ (Q_u.iff_ Q_v)),
    {
      apply is_deduct.mp_ ((eq_ r s).imp_ (P_u.iff_ P_v)),
      {
        unfold formula.iff_,
        unfold formula.and_,
        apply proof_imp_deduct,
        apply prop_complete,
        unfold formula.is_tauto_atomic,
        simp only [eval_not, eval_imp],
        tauto,
      },
      {
        exact h1_ih_1,
      }
    },
    {
      exact h1_ih_2,
    }
  },
  case is_repl_of_var_in_formula.forall_ : x P_u P_v h1_1 h1_ih
  {
    unfold is_bound_in at h2,
    push_neg at h2,
    cases h2,

    unfold is_bound_in at h3,
    push_neg at h3,
    cases h3,

    apply deduction_theorem,
    simp only [set.union_singleton, insert_emptyc_eq],
    apply is_deduct.mp_ (forall_ x (P_u.iff_ P_v)),
    {
      apply proof_imp_deduct,
      apply T_18_1,
    },
    {
      apply is_deduct.mp_ (eq_ r s),
      {
        apply proof_imp_deduct,
        apply is_deduct.mp_ (forall_ x ((eq_ r s).imp_ (P_u.iff_ P_v))),
        {
          apply T_19_TS_21_left,
          {
            unfold is_free_in,
            push_neg,
            split,
            {
              simp only [ne_comm],
              exact h2_left,
            },
            {
              simp only [ne_comm],
              exact h3_left,
            },
          },
        },
        {
          apply generalization,
          {
            exact h1_ih h2_right h3_right,
          },
          {
            intros H a1,
            simp only [set.mem_empty_eq] at a1,
            contradiction,
          },
        },
      },
      {
        apply is_deduct.assume_,
        simp only [set.mem_singleton],
      }
    },
  },
end

#lint


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies

! This file was ported from Lean 3 source module category_theory.category.Twop
! leanprover-community/mathlib commit c8ab806ef73c20cab1d87b5157e43a82c205f28e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Category.Bipointed
import Mathlib.Data.TwoPointing

/-!
# The category of two-pointed types

This defines `TwoP`, the category of two-pointed types.

## References

* [nLab, *coalgebra of the real interval*]
  (https://ncatlab.org/nlab/show/coalgebra+of+the+real+interval)
-/

open CategoryTheory Option

universe u

variable {α β : Type _}

set_option linter.uppercaseLean3 false

/-- The category of two-pointed types. -/
structure TwoP : Type (u + 1) where
  protected X : Type u
  toTwoPointing : TwoPointing X
#align Twop TwoP

namespace TwoP

instance : CoeSort TwoP (Type _) :=
  ⟨TwoP.X⟩

/-- Turns a two-pointing into a two-pointed type. -/
def of {X : Type _} (toTwoPointing : TwoPointing X) : TwoP :=
  ⟨X, toTwoPointing⟩
#align Twop.of TwoP.of

@[simp]
theorem coe_of {X : Type _} (toTwoPointing : TwoPointing X) : ↥(of toTwoPointing) = X :=
  rfl
#align Twop.coe_of TwoP.coe_of

alias of ← _root_.TwoPointing.TwoP
#align two_pointing.Twop TwoPointing.TwoP

instance : Inhabited TwoP :=
  ⟨of TwoPointing.bool⟩

/-- Turns a two-pointed type into a bipointed type, by forgetting that the pointed elements are
distinct. -/
noncomputable def toBipointed (X : TwoP) : Bipointed :=
  X.toTwoPointing.toProd.Bipointed
#align Twop.to_Bipointed TwoP.toBipointed

@[simp]
theorem coe_toBipointed (X : TwoP) : ↥X.toBipointed = ↥X :=
  rfl
#align Twop.coe_to_Bipointed TwoP.coe_toBipointed

noncomputable instance largeCategory : LargeCategory TwoP :=
  InducedCategory.category toBipointed
#align Twop.large_category TwoP.largeCategory

noncomputable instance concreteCategory : ConcreteCategory TwoP :=
  InducedCategory.concreteCategory toBipointed
#align Twop.concrete_category TwoP.concreteCategory

noncomputable instance hasForgetToBipointed : HasForget₂ TwoP Bipointed :=
  InducedCategory.hasForget₂ toBipointed
#align Twop.has_forget_to_Bipointed TwoP.hasForgetToBipointed

/-- Swaps the pointed elements of a two-pointed type. `TwoPointing.swap` as a functor. -/
@[simps]
noncomputable def swap : TwoP ⥤ TwoP where
  obj X := ⟨X, X.toTwoPointing.swap⟩
  map f := ⟨f.toFun, f.map_snd, f.map_fst⟩
#align Twop.swap TwoP.swap

/-- The equivalence between `TwoP` and itself induced by `Prod.swap` both ways. -/
@[simps!]
noncomputable def swapEquiv : TwoP ≌ TwoP :=
  CategoryTheory.Equivalence.mk swap swap
    (NatIso.ofComponents
      (fun X =>
        { hom := ⟨id, rfl, rfl⟩
          inv := ⟨id, rfl, rfl⟩ })
      fun f => rfl)
    (NatIso.ofComponents
      (fun X =>
        { hom := ⟨id, rfl, rfl⟩
          inv := ⟨id, rfl, rfl⟩ })
      fun f => rfl)
#align Twop.swap_equiv TwoP.swapEquiv

@[simp]
theorem swapEquiv_symm : swapEquiv.symm = swapEquiv :=
  rfl
#align Twop.swap_equiv_symm TwoP.swapEquiv_symm

end TwoP

@[simp]
theorem TwoP_swap_comp_forget_to_Bipointed :
    TwoP.swap ⋙ forget₂ TwoP Bipointed = forget₂ TwoP Bipointed ⋙ Bipointed.swap :=
  rfl
#align Twop_swap_comp_forget_to_Bipointed TwoP_swap_comp_forget_to_Bipointed

/-- The functor from `Pointed` to `TwoP` which adds a second point. -/
@[simps]
noncomputable def pointedToTwoPFst : Pointed.{u} ⥤ TwoP where
  obj X := ⟨Option X, ⟨X.point, none⟩, some_ne_none _⟩
  map f := ⟨Option.map f.toFun, congr_arg _ f.map_point, rfl⟩
  map_id _ := Bipointed.Hom.ext _ _ Option.map_id
  map_comp f g := Bipointed.Hom.ext _ _ (Option.map_comp_map f.1 g.1).symm
#align Pointed_to_Twop_fst pointedToTwoPFst

/-- The functor from `Pointed` to `TwoP` which adds a first point. -/
@[simps]
noncomputable def pointedToTwoPSnd : Pointed.{u} ⥤ TwoP where
  obj X := ⟨Option X, ⟨none, X.point⟩, (some_ne_none _).symm⟩
  map f := ⟨Option.map f.toFun, rfl, congr_arg _ f.map_point⟩
  map_id _ := Bipointed.Hom.ext _ _ Option.map_id
  map_comp f g := Bipointed.Hom.ext _ _ (Option.map_comp_map f.1 g.1).symm
#align Pointed_to_Twop_snd pointedToTwoPSnd

@[simp]
theorem pointedToTwoPFst_comp_swap : pointedToTwoPFst ⋙ TwoP.swap = pointedToTwoPSnd :=
  rfl
#align Pointed_to_Twop_fst_comp_swap pointedToTwoPFst_comp_swap

@[simp]
theorem pointedToTwoPSnd_comp_swap : pointedToTwoPSnd ⋙ TwoP.swap = pointedToTwoPFst :=
  rfl
#align Pointed_to_Twop_snd_comp_swap pointedToTwoPSnd_comp_swap

@[simp]
theorem pointedToTwoPFst_comp_forget_to_bipointed :
    pointedToTwoPFst ⋙ forget₂ TwoP Bipointed = pointedToBipointedFst :=
  rfl
#align Pointed_to_Twop_fst_comp_forget_to_Bipointed pointedToTwoPFst_comp_forget_to_bipointed

@[simp]
theorem pointedToTwoPSnd_comp_forget_to_bipointed :
    pointedToTwoPSnd ⋙ forget₂ TwoP Bipointed = pointedToBipointedSnd :=
  rfl
#align Pointed_to_Twop_snd_comp_forget_to_Bipointed pointedToTwoPSnd_comp_forget_to_bipointed

/-- Adding a second point is left adjoint to forgetting the second point. -/
noncomputable def pointedToTwoPFstForgetCompBipointedToPointedFstAdjunction :
    pointedToTwoPFst ⊣ forget₂ TwoP Bipointed ⋙ bipointedToPointedFst :=
  Adjunction.mkOfHomEquiv
    { homEquiv := fun X Y =>
        { toFun := fun f => ⟨f.toFun ∘ Option.some, f.map_fst⟩
          invFun := fun f => ⟨fun o => o.elim Y.toTwoPointing.toProd.2 f.toFun, f.map_point, rfl⟩
          left_inv := fun f => by
            apply Bipointed.Hom.ext
            funext x
            cases x
            exact f.map_snd.symm
            rfl
          right_inv := fun f => Pointed.Hom.ext _ _ rfl }
      homEquiv_naturality_left_symm := fun f g => by
        apply Bipointed.Hom.ext
        funext x
        cases x <;> rfl }
#align Pointed_to_Twop_fst_forget_comp_Bipointed_to_Pointed_fst_adjunction pointedToTwoPFstForgetCompBipointedToPointedFstAdjunction

/-- Adding a first point is left adjoint to forgetting the first point. -/
noncomputable def pointedToTwoPSndForgetCompBipointedToPointedSndAdjunction :
    pointedToTwoPSnd ⊣ forget₂ TwoP Bipointed ⋙ bipointedToPointedSnd :=
  Adjunction.mkOfHomEquiv
    { homEquiv := fun X Y =>
        { toFun := fun f => ⟨f.toFun ∘ Option.some, f.map_snd⟩
          invFun := fun f => ⟨fun o => o.elim Y.toTwoPointing.toProd.1 f.toFun, rfl, f.map_point⟩
          left_inv := fun f => by
            apply Bipointed.Hom.ext
            funext x
            cases x
            exact f.map_fst.symm
            rfl
          right_inv := fun f => Pointed.Hom.ext _ _ rfl }
      homEquiv_naturality_left_symm := fun f g => by
        apply Bipointed.Hom.ext
        funext x
        cases x <;> rfl }
#align Pointed_to_Twop_snd_forget_comp_Bipointed_to_Pointed_snd_adjunction pointedToTwoPSndForgetCompBipointedToPointedSndAdjunction


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import data.stream.defs
import tactic.ext

/-!
# Streams a.k.a. infinite lists a.k.a. infinite sequences

This file used to be in the core library. It was moved to `mathlib` and renamed to `init` to avoid
name clashes.  -/

open nat function option

universes u v w

namespace stream
variables {α : Type u} {β : Type v} {δ : Type w}

instance {α} [inhabited α] : inhabited (stream α) :=
⟨stream.const (default _)⟩

protected theorem eta (s : stream α) : head s :: tail s = s :=
funext (λ i, begin cases i; refl end)

theorem nth_zero_cons (a : α) (s : stream α) : nth (a :: s) 0 = a := rfl

theorem head_cons (a : α) (s : stream α) : head (a :: s) = a := rfl

theorem tail_cons (a : α) (s : stream α) : tail (a :: s) = s := rfl

theorem tail_drop (n : nat) (s : stream α) : tail (drop n s) = drop n (tail s) :=
funext (λ i, begin unfold tail drop, simp [nth, nat.add_comm, nat.add_left_comm] end)

theorem nth_drop (n m : nat) (s : stream α) : nth (drop m s) n = nth s (n + m) := rfl

theorem tail_eq_drop (s : stream α) : tail s = drop 1 s := rfl

theorem drop_drop (n m : nat) (s : stream α) : drop n (drop m s) = drop (n+m) s :=
funext (λ i, begin unfold drop, rw nat.add_assoc end)

theorem nth_succ (n : nat) (s : stream α) : nth s (succ n) = nth (tail s) n := rfl

theorem drop_succ (n : nat) (s : stream α) : drop (succ n) s = drop n (tail s) := rfl

@[simp] lemma head_drop {α} (a : stream α) (n : ℕ) : (a.drop n).head = a.nth n :=
by simp only [drop, head, nat.zero_add, stream.nth]

@[ext] protected theorem ext {s₁ s₂ : stream α} : (∀ n, nth s₁ n = nth s₂ n) → s₁ = s₂ :=
assume h, funext h

theorem all_def (p : α → Prop) (s : stream α) : all p s = ∀ n, p (nth s n) := rfl

theorem any_def (p : α → Prop) (s : stream α) : any p s = ∃ n, p (nth s n) := rfl

theorem mem_cons (a : α) (s : stream α) : a ∈ (a::s) :=
exists.intro 0 rfl

theorem mem_cons_of_mem {a : α} {s : stream α} (b : α) : a ∈ s → a ∈ b :: s :=
assume ⟨n, h⟩,
exists.intro (succ n) (by rw [nth_succ, tail_cons, h])

theorem eq_or_mem_of_mem_cons {a b : α} {s : stream α} : a ∈ b::s → a = b ∨ a ∈ s :=
assume ⟨n, h⟩,
begin
  cases n with n',
  { left, exact h },
  { right, rw [nth_succ, tail_cons] at h, exact ⟨n', h⟩ }
end

theorem mem_of_nth_eq {n : nat} {s : stream α} {a : α} : a = nth s n → a ∈ s :=
assume h, exists.intro n h

section map
variable (f : α → β)

theorem drop_map (n : nat) (s : stream α) : drop n (map f s) = map f (drop n s) :=
stream.ext (λ i, rfl)

theorem nth_map (n : nat) (s : stream α) : nth (map f s) n = f (nth s n) := rfl

theorem tail_map (s : stream α) : tail (map f s) = map f (tail s) :=
begin rw tail_eq_drop, refl end

theorem head_map (s : stream α) : head (map f s) = f (head s) := rfl

theorem map_eq (s : stream α) : map f s = f (head s) :: map f (tail s) :=
by rw [← stream.eta (map f s), tail_map, head_map]

theorem map_cons (a : α) (s : stream α) : map f (a :: s) = f a :: map f s :=
begin rw [← stream.eta (map f (a :: s)), map_eq], refl end

theorem map_id (s : stream α) : map id s = s := rfl

theorem map_map (g : β → δ) (f : α → β) (s : stream α) : map g (map f s) = map (g ∘ f) s := rfl

theorem map_tail (s : stream α) : map f (tail s) = tail (map f s) := rfl

theorem mem_map {a : α} {s : stream α} : a ∈ s → f a ∈ map f s :=
assume ⟨n, h⟩,
exists.intro n (by rw [nth_map, h])

theorem exists_of_mem_map {f} {b : β} {s : stream α} : b ∈ map f s → ∃ a, a ∈ s ∧ f a = b :=
assume ⟨n, h⟩, ⟨nth s n, ⟨n, rfl⟩, h.symm⟩
end map

section zip
variable (f : α → β → δ)

theorem drop_zip (n : nat) (s₁ : stream α) (s₂ : stream β) :
  drop n (zip f s₁ s₂) = zip f (drop n s₁) (drop n s₂) :=
stream.ext (λ i, rfl)

theorem nth_zip (n : nat) (s₁ : stream α) (s₂ : stream β) :
  nth (zip f s₁ s₂) n = f (nth s₁ n) (nth s₂ n) := rfl

theorem head_zip (s₁ : stream α) (s₂ : stream β) : head (zip f s₁ s₂) = f (head s₁) (head s₂) := rfl

theorem tail_zip (s₁ : stream α) (s₂ : stream β) :
  tail (zip f s₁ s₂) = zip f (tail s₁) (tail s₂) := rfl

theorem zip_eq (s₁ : stream α) (s₂ : stream β) :
  zip f s₁ s₂ = f (head s₁) (head s₂) :: zip f (tail s₁) (tail s₂) :=
begin rw [← stream.eta (zip f s₁ s₂)], refl end

end zip

theorem mem_const (a : α) : a ∈ const a :=
exists.intro 0 rfl

theorem const_eq (a : α) : const a = a :: const a :=
begin
  apply stream.ext, intro n,
  cases n; refl
end

theorem tail_const (a : α) : tail (const a) = const a :=
suffices tail (a :: const a) = const a, by rwa [← const_eq] at this, rfl

theorem map_const (f : α → β) (a : α) : map f (const a) = const (f a) := rfl

theorem nth_const (n : nat) (a : α) : nth (const a) n = a := rfl

theorem drop_const (n : nat) (a : α) : drop n (const a) = const a :=
stream.ext (λ i, rfl)

theorem head_iterate (f : α → α) (a : α) : head (iterate f a) = a := rfl

theorem tail_iterate (f : α → α) (a : α) : tail (iterate f a) = iterate f (f a) :=
begin
  funext n,
  induction n with n' ih,
  { refl },
  { unfold tail iterate,
    unfold tail iterate at ih,
    rw add_one at ih, dsimp at ih,
    rw add_one, dsimp, rw ih }
end

theorem iterate_eq (f : α → α) (a : α) : iterate f a = a :: iterate f (f a) :=
begin
  rw [← stream.eta (iterate f a)],
  rw tail_iterate, refl
end

theorem nth_zero_iterate (f : α → α) (a : α) : nth (iterate f a) 0 = a := rfl

theorem nth_succ_iterate (n : nat) (f : α → α) (a : α) :
  nth (iterate f a) (succ n) = nth (iterate f (f a)) n :=
by rw [nth_succ, tail_iterate]

section bisim
  variable (R : stream α → stream α → Prop)
  local infix ` ~ `:50 := R

  def is_bisimulation := ∀ ⦃s₁ s₂⦄, s₁ ~ s₂ → head s₁ = head s₂ ∧ tail s₁ ~ tail s₂

  theorem nth_of_bisim (bisim : is_bisimulation R) :
    ∀ {s₁ s₂} n, s₁ ~ s₂ → nth s₁ n = nth s₂ n ∧ drop (n+1) s₁ ~ drop (n+1) s₂
  | s₁ s₂ 0     h := bisim h
  | s₁ s₂ (n+1) h :=
    match bisim h with
    | ⟨h₁, trel⟩ := nth_of_bisim n trel
    end

  -- If two streams are bisimilar, then they are equal
  theorem eq_of_bisim (bisim : is_bisimulation R) : ∀ {s₁ s₂}, s₁ ~ s₂ → s₁ = s₂ :=
  λ s₁ s₂ r, stream.ext (λ n, and.elim_left (nth_of_bisim R bisim n r))
end bisim

theorem bisim_simple (s₁ s₂ : stream α) :
  head s₁ = head s₂ → s₁ = tail s₁ → s₂ = tail s₂ → s₁ = s₂ :=
assume hh ht₁ ht₂, eq_of_bisim
  (λ s₁ s₂, head s₁ = head s₂ ∧ s₁ = tail s₁ ∧ s₂ = tail s₂)
  (λ s₁ s₂ ⟨h₁, h₂, h₃⟩,
    begin
      constructor, exact h₁, rw [← h₂, ← h₃], repeat { constructor }; assumption
    end)
  (and.intro hh (and.intro ht₁ ht₂))

theorem coinduction {s₁ s₂ : stream α} :
  head s₁ = head s₂ → (∀ (β : Type u) (fr : stream α → β), fr s₁ = fr s₂ →
    fr (tail s₁) = fr (tail s₂)) → s₁ = s₂ :=
assume hh ht,
  eq_of_bisim
    (λ s₁ s₂, head s₁ = head s₂ ∧ ∀ (β : Type u) (fr : stream α → β), fr s₁ = fr s₂ →
      fr (tail s₁) = fr (tail s₂))
    (λ s₁ s₂ h,
      have h₁ : head s₁ = head s₂,               from and.elim_left h,
      have h₂ : head (tail s₁) = head (tail s₂), from and.elim_right h α (@head α) h₁,
      have h₃ : ∀ (β : Type u) (fr : stream α → β),
        fr (tail s₁) = fr (tail s₂) → fr (tail (tail s₁)) = fr (tail (tail s₂)),
      from λ β fr, and.elim_right h β (λ s, fr (tail s)),
      and.intro h₁ (and.intro h₂ h₃))
    (and.intro hh ht)

theorem iterate_id (a : α) : iterate id a = const a :=
coinduction
  rfl
  (λ β fr ch, begin rw [tail_iterate, tail_const], exact ch end)

local attribute [reducible] stream
theorem map_iterate (f : α → α) (a : α) : iterate f (f a) = map f (iterate f a) :=
begin
  funext n,
  induction n with n' ih,
  { refl },
  { unfold map iterate nth, dsimp,
    unfold map iterate nth at ih, dsimp at ih,
    rw ih }
end

section corec
theorem corec_def (f : α → β) (g : α → α) (a : α) : corec f g a = map f (iterate g a) := rfl

theorem corec_eq (f : α → β) (g : α → α) (a : α) : corec f g a = f a :: corec f g (g a) :=
begin rw [corec_def, map_eq, head_iterate, tail_iterate], refl end

theorem corec_id_id_eq_const (a : α) : corec id id a = const a :=
by rw [corec_def, map_id, iterate_id]

theorem corec_id_f_eq_iterate (f : α → α) (a : α) : corec id f a = iterate f a := rfl
end corec

section corec'

theorem corec'_eq (f : α → β × α) (a : α) : corec' f a = (f a).1 :: corec' f (f a).2 :=
corec_eq _ _ _

end corec'

theorem unfolds_eq (g : α → β) (f : α → α) (a : α) : unfolds g f a = g a :: unfolds g f (f a) :=
begin unfold unfolds, rw [corec_eq] end

theorem nth_unfolds_head_tail : ∀ (n : nat) (s : stream α), nth (unfolds head tail s) n = nth s n :=
begin
  intro n, induction n with n' ih,
  { intro s, refl },
  { intro s, rw [nth_succ, nth_succ, unfolds_eq, tail_cons, ih] }
end

theorem unfolds_head_eq : ∀ (s : stream α), unfolds head tail s = s :=
λ s, stream.ext (λ n, nth_unfolds_head_tail n s)

theorem interleave_eq (s₁ s₂ : stream α) : s₁ ⋈ s₂ = head s₁ :: head s₂ :: (tail s₁ ⋈ tail s₂) :=
begin
  unfold interleave corec_on, rw corec_eq, dsimp, rw corec_eq, refl
end

theorem tail_interleave (s₁ s₂ : stream α) : tail (s₁ ⋈ s₂) = s₂ ⋈ (tail s₁) :=
begin unfold interleave corec_on, rw corec_eq, refl end

theorem interleave_tail_tail (s₁ s₂ : stream α) : tail s₁ ⋈ tail s₂ = tail (tail (s₁ ⋈ s₂)) :=
begin rw [interleave_eq s₁ s₂], refl end

theorem nth_interleave_left : ∀ (n : nat) (s₁ s₂ : stream α), nth (s₁ ⋈ s₂) (2 * n) = nth s₁ n
| 0        s₁ s₂ := rfl
| (succ n) s₁ s₂ :=
  begin
    change nth (s₁ ⋈ s₂) (succ (succ (2*n))) = nth s₁ (succ n),
    rw [nth_succ, nth_succ, interleave_eq, tail_cons, tail_cons, nth_interleave_left],
    refl
  end

theorem nth_interleave_right : ∀ (n : nat) (s₁ s₂ : stream α), nth (s₁ ⋈ s₂) (2*n+1) = nth s₂ n
| 0        s₁ s₂ := rfl
| (succ n) s₁ s₂ :=
  begin
    change nth (s₁ ⋈ s₂) (succ (succ (2*n+1))) = nth s₂ (succ n),
    rw [nth_succ, nth_succ, interleave_eq, tail_cons, tail_cons, nth_interleave_right],
    refl
  end

theorem mem_interleave_left {a : α} {s₁ : stream α} (s₂ : stream α) : a ∈ s₁ → a ∈ s₁ ⋈ s₂ :=
assume ⟨n, h⟩,
exists.intro (2*n) (by rw [h, nth_interleave_left])

theorem mem_interleave_right {a : α} {s₁ : stream α} (s₂ : stream α) : a ∈ s₂ → a ∈ s₁ ⋈ s₂ :=
assume ⟨n, h⟩,
exists.intro (2*n+1) (by rw [h, nth_interleave_right])

theorem odd_eq (s : stream α) : odd s = even (tail s) := rfl

theorem head_even (s : stream α) : head (even s) = head s := rfl

theorem tail_even (s : stream α) : tail (even s) = even (tail (tail s)) :=
begin unfold even, rw corec_eq, refl end

theorem even_cons_cons (a₁ a₂ : α) (s : stream α) : even (a₁ :: a₂ :: s) = a₁ :: even s :=
begin unfold even, rw corec_eq, refl end

theorem even_tail (s : stream α) : even (tail s) = odd s := rfl

theorem even_interleave (s₁ s₂ : stream α) : even (s₁ ⋈ s₂) = s₁ :=
eq_of_bisim
  (λ s₁' s₁, ∃ s₂, s₁' = even (s₁ ⋈ s₂))
  (λ s₁' s₁ ⟨s₂, h₁⟩,
    begin
      rw h₁,
      constructor,
       {refl},
       {exact ⟨tail s₂, by rw [interleave_eq, even_cons_cons, tail_cons]⟩}
    end)
  (exists.intro s₂ rfl)

theorem interleave_even_odd (s₁ : stream α) : even s₁ ⋈ odd s₁ = s₁ :=
eq_of_bisim
  (λ s' s, s' = even s ⋈ odd s)
  (λ s' s (h : s' = even s ⋈ odd s),
    begin
      rw h, constructor,
       {refl},
       {simp [odd_eq, odd_eq, tail_interleave, tail_even]}
    end)
  rfl

theorem nth_even : ∀ (n : nat) (s : stream α), nth (even s) n = nth s (2*n)
| 0        s := rfl
| (succ n) s :=
  begin
    change nth (even s) (succ n) = nth s (succ (succ (2 * n))),
    rw [nth_succ, nth_succ, tail_even, nth_even], refl
  end

theorem nth_odd : ∀ (n : nat) (s : stream α), nth (odd s) n = nth s (2 * n + 1) :=
λ n s, begin rw [odd_eq, nth_even], refl end

theorem mem_of_mem_even (a : α) (s : stream α) : a ∈ even s → a ∈ s :=
assume ⟨n, h⟩,
exists.intro (2*n) (by rw [h, nth_even])

theorem mem_of_mem_odd (a : α) (s : stream α) : a ∈ odd s → a ∈ s :=
assume ⟨n, h⟩,
exists.intro (2*n+1) (by rw [h, nth_odd])

theorem nil_append_stream (s : stream α) : append_stream [] s = s := rfl

theorem cons_append_stream (a : α) (l : list α) (s : stream α) :
  append_stream (a::l) s = a :: append_stream l s := rfl

theorem append_append_stream :
  ∀ (l₁ l₂ : list α) (s : stream α), (l₁ ++ l₂) ++ₛ s = l₁ ++ₛ (l₂ ++ₛ s)
| []               l₂ s := rfl
| (list.cons a l₁) l₂ s := by rw [list.cons_append, cons_append_stream, cons_append_stream,
                                  append_append_stream]

theorem map_append_stream (f : α → β) :
  ∀ (l : list α) (s : stream α), map f (l ++ₛ s) = list.map f l ++ₛ map f s
| []              s := rfl
| (list.cons a l) s := by rw [cons_append_stream, list.map_cons, map_cons, cons_append_stream,
                              map_append_stream]

theorem drop_append_stream : ∀ (l : list α) (s : stream α), drop l.length (l ++ₛ s) = s
| []              s := by refl
| (list.cons a l) s := by rw [list.length_cons, add_one, drop_succ, cons_append_stream, tail_cons,
                              drop_append_stream]

theorem append_stream_head_tail (s : stream α) : [head s] ++ₛ tail s = s :=
by rw [cons_append_stream, nil_append_stream, stream.eta]

theorem mem_append_stream_right : ∀ {a : α} (l : list α) {s : stream α}, a ∈ s → a ∈ l ++ₛ s
| a []              s h := h
| a (list.cons b l) s h :=
  have ih : a ∈ l ++ₛ s, from mem_append_stream_right l h,
  mem_cons_of_mem _ ih

theorem mem_append_stream_left : ∀ {a : α} {l : list α} (s : stream α), a ∈ l → a ∈ l ++ₛ s
| a []     s h := absurd h (list.not_mem_nil _)
| a (list.cons b l) s h :=
  or.elim (list.eq_or_mem_of_mem_cons h)
    (λ (aeqb : a = b), exists.intro 0 aeqb)
    (λ (ainl : a ∈ l), mem_cons_of_mem b (mem_append_stream_left s ainl))

@[simp] theorem take_zero (s : stream α) : take 0 s = [] := rfl

@[simp] theorem take_succ (n : nat) (s : stream α) :
  take (succ n) s = head s :: take n (tail s) := rfl

@[simp] theorem length_take (n : ℕ) (s : stream α) : (take n s).length = n :=
by induction n generalizing s; simp *

theorem nth_take_succ : ∀ (n : nat) (s : stream α), list.nth (take (succ n) s) n = some (nth s n)
| 0     s := rfl
| (n+1) s := begin rw [take_succ, add_one, list.nth, nth_take_succ], refl end

theorem append_take_drop :
  ∀ (n : nat) (s : stream α), append_stream (take n s) (drop n s) = s :=
begin
  intro n,
  induction n with n' ih,
  { intro s, refl },
  { intro s, rw [take_succ, drop_succ, cons_append_stream, ih (tail s), stream.eta] }
end

-- Take theorem reduces a proof of equality of infinite streams to an
-- induction over all their finite approximations.
theorem take_theorem (s₁ s₂ : stream α) : (∀ (n : nat), take n s₁ = take n s₂) → s₁ = s₂ :=
begin
  intro h, apply stream.ext, intro n,
  induction n with n ih,
  { have aux := h 1, simp [take] at aux, exact aux },
  { have h₁ : some (nth s₁ (succ n)) = some (nth s₂ (succ n)),
    { rw [← nth_take_succ, ← nth_take_succ, h (succ (succ n))] },
    injection h₁ }
end

protected lemma cycle_g_cons (a : α) (a₁ : α) (l₁ : list α) (a₀ : α) (l₀ : list α) :
              stream.cycle_g (a, a₁::l₁, a₀, l₀) = (a₁, l₁, a₀, l₀) := rfl

theorem cycle_eq : ∀ (l : list α) (h : l ≠ []), cycle l h = l ++ₛ cycle l h
| []              h := absurd rfl h
| (list.cons a l) h :=
  have gen : ∀ l' a', corec stream.cycle_f stream.cycle_g (a', l', a, l) =
    (a' :: l') ++ₛ corec stream.cycle_f stream.cycle_g (a, l, a, l),
    begin
      intro l',
      induction l' with a₁ l₁ ih,
        {intros, rw [corec_eq], refl},
        {intros, rw [corec_eq, stream.cycle_g_cons, ih a₁], refl}
    end,
  gen l a

theorem mem_cycle {a : α} {l : list α} : ∀ (h : l ≠ []), a ∈ l → a ∈ cycle l h :=
assume h ainl, begin rw [cycle_eq], exact mem_append_stream_left _ ainl end

theorem cycle_singleton (a : α) (h : [a] ≠ []) : cycle [a] h = const a :=
coinduction
  rfl
  (λ β fr ch, by rwa [cycle_eq, const_eq])

theorem tails_eq (s : stream α) : tails s = tail s :: tails (tail s) :=
by unfold tails; rw [corec_eq]; refl

theorem nth_tails : ∀ (n : nat) (s : stream α), nth (tails s) n = drop n (tail s) :=
begin
  intro n, induction n with n' ih,
  { intros, refl },
  { intro s, rw [nth_succ, drop_succ, tails_eq, tail_cons, ih] }
end

theorem tails_eq_iterate (s : stream α) : tails s = iterate tail (tail s) := rfl

theorem inits_core_eq (l : list α) (s : stream α) :
  inits_core l s = l :: inits_core (l ++ [head s]) (tail s) :=
begin unfold inits_core corec_on, rw [corec_eq], refl end

theorem tail_inits (s : stream α) :
  tail (inits s) = inits_core [head s, head (tail s)] (tail (tail s)) :=
begin unfold inits, rw inits_core_eq, refl end

theorem inits_tail (s : stream α) :
  inits (tail s) = inits_core [head (tail s)] (tail (tail s)) := rfl

theorem nth_inits : ∀ (n : nat) (s : stream α), nth (inits s) n = take (succ n) s  :=
begin
  intro n, induction n with n' ih,
  { intros, refl },
  { intros, rw [nth_succ, take_succ, ← ih, tail_inits, inits_tail, cons_nth_inits_core] }
end

theorem inits_eq (s : stream α) : inits s = [head s] :: map (list.cons (head s)) (inits (tail s)) :=
begin
  apply stream.ext, intro n,
  cases n,
  { refl },
  { rw [nth_inits, nth_succ, tail_cons, nth_map, nth_inits], refl }
end

theorem zip_inits_tails (s : stream α) : zip append_stream (inits s) (tails s) = const s :=
begin
  apply stream.ext, intro n,
  rw [nth_zip, nth_inits, nth_tails, nth_const, take_succ,
      cons_append_stream, append_take_drop, stream.eta]
end

theorem identity (s : stream α) : pure id ⊛ s = s := rfl
theorem composition (g : stream (β → δ)) (f : stream (α → β)) (s : stream α) :
  pure comp ⊛ g ⊛ f ⊛ s = g ⊛ (f ⊛ s) := rfl
theorem homomorphism (f : α → β) (a : α) : pure f ⊛ pure a = pure (f a) := rfl
theorem interchange (fs : stream (α → β)) (a : α) :
  fs ⊛ pure a = pure (λ f : α → β, f a) ⊛ fs := rfl
theorem map_eq_apply (f : α → β) (s : stream α) : map f s = pure f ⊛ s := rfl

theorem nth_nats (n : nat) : nth nats n = n := rfl

theorem nats_eq : nats = 0 :: map succ nats :=
begin
  apply stream.ext, intro n,
  cases n, refl, rw [nth_succ], refl
end

end stream


/- Introduces typing contexts, which are lists of assumptions with associated
   multiplicities from an arbitrary semiring. -/

import tactic.ring
import tactic.abel
import algebra

import metastuff
import sesh.types
import sesh.mult

/- In the QTT paper, this would be a "pre-precontext". -/
@[reducible]
def precontext := list tp

/- In the QTT paper, this is the "precontext".
   τ is the Lean Type representing types of the embedded language.
   mult is the Lean Type representing elements of an arbitrary semiring,
   which describe the multiplicity of resources (how many times a resource
   can or will be used). -/
inductive context: precontext → Type
| nil: context []
-- "You have a dependent pi (n) after a recursive arg (_ : context ns)
-- and Lean doesn't like this."
| cons {γ: precontext} (π: mult) (T: tp): context γ → context (T::γ)
notation `⟦`π`⬝`T`⟧::`Γ:90 := context.cons π T Γ

/- Indexes a judgment in the typing context. Definition follows
   the inductive structure of natural numbers. -/
inductive debrujin_idx: precontext → tp → Type
infix ` ∋ `:55 := debrujin_idx
| ZVar: Π (γ: precontext) (T: tp),
  ----------
  (T::γ) ∋ T
| SVar: Π {γ: precontext} {T: tp} (U: tp),
  γ ∋ T
  ----------
→ (U::γ) ∋ T
infix ` ∋ `:55 := debrujin_idx

namespace context

-- An ugly hack which makes the contexts non-generic, but rather specific
-- to `tp`. Necessary because generic lemmas make `simp` slow to the point
-- of timing out and being generally unusable. This whole module should
-- still work when the variables are reintroduced.
--variable {τ: Type}
@[reducible]
def τ := tp
--variables {mult: Type} [semiring mult]

def zeros: Π (γ: precontext), context γ
| [] := nil
| (T::δ) := ⟦0⬝T⟧::(zeros δ)

instance {γ: precontext} : has_zero (context γ) :=
  ⟨zeros γ⟩

@[unfold_] lemma zeros_nil
  : (0: context []) = nil := by refl

@[unfold_] lemma zeros_cons {γ: precontext} {T: τ}
  : (0: context (T::γ)) = ⟦(0: mult)⬝T⟧::(0: context γ) := by refl

protected def add: Π {γ}, context γ → context γ → context γ
| _ nil nil := nil
| _ (⟦π₁⬝T⟧::Γ₁) (⟦π₂⬝.(T)⟧::Γ₂) := ⟦(π₁+π₂)⬝T⟧::(add Γ₁ Γ₂)

instance {γ: precontext} : has_add (context γ) :=
  ⟨context.add⟩

@[simp] lemma add_nil
  : (nil: context []) + nil = nil := by refl

@[unfold_] lemma add_cons {γ} {Γ₁ Γ₂: context γ} {π₁ π₂: mult} {T: τ}
  : ⟦π₁⬝T⟧::Γ₁ + ⟦π₂⬝T⟧::Γ₂ = ⟦(π₁+π₂)⬝T⟧::(Γ₁ + Γ₂) := by refl

/- addition makes a commutative monoid -/

@[simp] lemma zero_add
  : ∀ {γ} {Γ: context γ},
    0 + Γ = Γ :=
begin
  intros,
  induction Γ with γ π T Γ ih,
  { refl },
  { unfold has_zero.zero zeros at *,
    simp * with unfold_, show 0+π=π,
    abel },
end

@[simp] lemma add_zero
  : ∀ {γ} {Γ: context γ},
    Γ + 0 = Γ :=
begin
  intros,
  induction Γ with γ π T Γ ih,
  { refl },
  { unfold has_zero.zero zeros at *,
    simp * with unfold_, show 0+π=π,
    abel },
end

lemma zeros_left {γ} {Γ₁ Γ₂: context γ}
  (h: Γ₁ + Γ₂ = 0)
  : Γ₁ = 0 :=
begin
  induction Γ₁ with γ π T Γ ih,
  { unfold has_zero.zero zeros },
  { cases Γ₂ with _ π₂ _ Γ₂,
    unfold has_zero.zero zeros at h,
    rw [add_cons] at h, simp at h,
    congr' 1,
    { exact mult.zeros_left h.left },
    { exact ih h.right },
  }
end

lemma zeros_right {γ} {Γ₁ Γ₂: context γ}
  (h: Γ₁ + Γ₂ = 0)
  : Γ₂ = 0 :=
begin
  induction Γ₂ with γ π T Γ ih,
  { unfold has_zero.zero zeros },
  { cases Γ₁ with _ π₁ _ Γ₁,
    unfold has_zero.zero zeros at h,
    rw [add_cons] at h, simp at h,
    congr' 1,
    { exact mult.zeros_left h.left },
    { exact ih h.right },
  }
end

lemma add_comm
  : ∀ {γ} {Γ₁ Γ₂: context γ},
    Γ₁ + Γ₂ = Γ₂ + Γ₁ :=
begin
  intros,
  induction Γ₁ with γ₁ π₁ T₁ Γ₁ ih₁,
  { cases Γ₂, refl },
  { cases Γ₂ with _ π₂,
    simp * with unfold_ },
end

lemma add_assoc
  : ∀ {γ} {Γ₁ Γ₂ Γ₃: context γ},
    (Γ₁ + Γ₂) + Γ₃ = Γ₁ + (Γ₂ + Γ₃) :=
begin
  intros,
  induction Γ₁ with γ₁ π₁ T₁ Γ₁ ih₁,
  { cases Γ₂, cases Γ₃, refl },
  { cases Γ₂ with _ π₂,
    cases Γ₃ with _ π₃,
    simp * with unfold_ },
end

instance {γ: precontext} : add_comm_monoid (context γ) :=
{ add := context.add,
  zero := zeros γ,
  zero_add := @zero_add γ,
  add_zero := @add_zero γ,
  add_comm := @add_comm γ,
  add_assoc := @add_assoc γ }

protected def smul: Π {γ}, mult → context γ → context γ
| _ π nil := nil
| _ π (⟦π'⬝T⟧::Γ) := ⟦(π*π')⬝T⟧::(smul π Γ)

instance {γ: precontext} : has_scalar mult (context γ) :=
  ⟨context.smul⟩

@[simp] lemma smul_nil {π: mult}
  : π • (nil: context []) = nil := by refl

@[unfold_] lemma smul_cons {γ} {Γ: context γ} {π π': mult} {T: τ}
  : π • ⟦π'⬝T⟧::Γ = ⟦(π*π')⬝T⟧::(π • Γ) := by refl

/- scalar multiplication (mult • context) makes a semimodule -/

@[simp] lemma one_smul
  : ∀ {γ} {Γ: context γ},
    ((1: mult) • Γ: context γ) = Γ :=
begin
  intros,
  induction Γ with γ π T Δ ih,
  { refl },
  { simp * with unfold_ },
end

@[simp] lemma zero_smul
  : ∀ {γ} {Γ: context γ},
    ((0: mult) • Γ: context γ) = 0 :=
begin
  intros,
  induction Γ with γ π T Γ ih,
  { refl },
  { simp * with unfold_ },
end

@[simp] lemma smul_zero
  : ∀ {γ} {π: mult},
    (π • 0: context γ) = 0 :=
begin
  intros,
  induction γ with T γ ih,
  { refl },
  { unfold has_zero.zero zeros,
    unfold has_zero.zero zeros at ih,
    simp * with unfold_,
    show π*0=0, simp * },
end

@[sop_form] lemma smul_add
  : ∀ {γ} {π: mult} {Γ₁ Γ₂: context γ},
    π • (Γ₁ + Γ₂) = π•Γ₁ + π•Γ₂ :=
begin
  intros,
  induction Γ₁ with γ₁ π₁ T₁ Γ₁ ih₁,
  { cases Γ₂, refl },
  { cases Γ₂ with _ π₂,
    simp [*, left_distrib] with unfold_ },
end

@[sop_form] lemma add_smul
  : ∀ {γ} {π₁ π₂: mult} {Γ: context γ},
    (π₁ + π₂) • Γ = π₁•Γ + π₂•Γ :=
begin
  intros,
  induction Γ with γ π T Γ ih,
  { refl },
  { simp [*, right_distrib] with unfold_ },
end

lemma mul_smul
  : ∀ {γ} {π π': mult} {Γ: context γ},
    (π * π') • Γ = π • (π' • Γ) :=
begin
  intros, induction Γ with γ π T Γ ih,
  { refl },
  { simp [*, mul_assoc] with unfold_ },
end

instance {γ: precontext} : semimodule mult (context γ) :=
{ one_smul := @one_smul γ,
  zero_smul := @zero_smul γ,
  smul_zero := @smul_zero γ,
  smul_add := @smul_add γ,
  add_smul := @add_smul γ,
  mul_smul := @mul_smul γ }

end context