/-
Copyright (c) 2022 Youjack. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Youjack
-/
import cycle

/-!
# The SECOND Law and Carnot Theorem

This file defines
* the notion of `cycle`'s satisfying the second law, i.e. `cycle.possible`
* the notion of reversible `cycle`, i.e. `cycle.reversible`
and states
* axioms stating the possibility of some types of `cycle`s, including
  `cycle.trivial_possible`,
  `one_rsv_cycle.exists_possible_dissipate'`, `abs_rel_cycle.exists_possible_transfer'`,
  `usual_engine_cycle.exists_possible`, `usual_pump_cycle.exists_possible`
* axioms stating that connection and scaling preserve the possibility of `cycle`s,
  i.e. `cycle.possible_add` and `cycle.possible_smul_nonneg`
* the axiom of the second law, i.e. `kelvin_stmt`
and proves
* the equivalence of Kelvin-Plank statement and Clausius's statement
* the equivalence of Clausius's statement and Carnot theorem
-/

namespace thermodynamics

/-!
## `possible` `cycle`s
---------------------------------------------------------------------------------------------------/

namespace cycle

/-- abstract `cycle` that is possible according to the second law -/
constant possible : cycle → Prop
/-- The trivial `cycle` is possible. -/
axiom trivial_possible : (0:cycle).possible

/-- The connection of two possible `cycle`s is possible.
* Note that a connection of possible and impossible can be possible.
-/
axiom possible_add {H₁ H₂ : cycle} : H₁.possible → H₂.possible → (H₁ + H₂).possible
/-- The scaling a possible `cycle` with nonnegative is possible. -/
axiom possible_smul_nonneg {c : ℝ} {H : cycle} : 0 ≤ c → H.possible → (c • H).possible

end cycle

/-!
### `one_rsv_cycle`
-/

namespace one_rsv_cycle
variables {𝓣 : reservoir}

/-- There exists possible `one_rsv_cycle 𝓣` that `dissipate`s work into heat. -/
axiom exists_possible_dissipate' : ∃ H : one_rsv_cycle 𝓣, H.possible ∧ H.𝓦 < 0

/- /-- There exists possible `one_rsv_cycle 𝓣` that dissipates a certain work `W > 0`. -/
lemma exists_psbl_dissi {W : ℝ} (hW : 0 < W) :
  ∃ H : one_rsv_cycle 𝓣, H.possible ∧ H.𝓦 = W := sorry -/

end one_rsv_cycle

/-!
### `abs_rel_cycle`
-/

namespace abs_rel_cycle
variables {𝓗 𝓒 : reservoir}

/-- There exists possible `abs_rel_cycle` that
    abs from hotter `𝓗` and fully `transfer`s it to colder `𝓒`. -/
axiom exists_possible_transfer' (𝓒_lt_𝓗 : 𝓒 < 𝓗) :
  ∃ H : abs_rel_cycle 𝓗 𝓒, H.possible ∧ (H.Qabs:ℝ) = H.Qrel
--

/- /-- There exists possible `abs_rel_cycle 𝓗 𝓒` that transfers a certain heat `Q > 0`. -/
lemma exists_psbl_trans (𝓒_lt_𝓗 : 𝓒 < 𝓗) {Q : ℝ} (hQ : 0 < Q) :
  ∃ H : abs_rel_cycle 𝓗 𝓒, H.possible ∧ (H.Qabs:ℝ) = H.Qrel ∧ ↑H.Qabs = Q := sorry -/

end abs_rel_cycle

/-!
### `usual_engine_cycle`
-/

namespace usual_engine_cycle
variables {𝓗 𝓒 : reservoir} (𝓒_lt_𝓗 : 𝓒 < 𝓗)

/-- There exists a possible `usual_engine_cycle` between any `𝓒 < 𝓗`. -/
axiom exists_possible : ∃ H : usual_engine_cycle 𝓒_lt_𝓗, H.possible

variables {Q : ℝ} (hQ : 0 < Q)
/-- There exists possible `usual_engine_cycle 𝓒_lt_𝓗` that absorbs a certain heat `Q > 0`. -/
lemma exists_psbl_abs : ∃ H : usual_engine_cycle 𝓒_lt_𝓗, H.possible ∧ ↑H.Qabs = Q :=
  let ⟨H', hH'⟩ := exists_possible 𝓒_lt_𝓗 in
  let c : ℝ₊ := ⟨Q / H'.Qabs, div_pos hQ H'.do_abs⟩ in
  let H := c • H' in
  ⟨ H,
    cycle.possible_smul_nonneg (le_of_lt c.property) hH',
    calc ↑H.Qabs
         = Q / H'.Qabs * H'.Qabs : cycle.Qabs_smul_pos c.property
      ...= Q                     : div_mul_cancel _ (ne_of_gt H'.do_abs), ⟩
/-- There exists possible `usual_engine_cycle 𝓒_lt_𝓗` that releases a certain heat `Q > 0`. -/
lemma exists_psbl_rel : ∃ H : usual_engine_cycle 𝓒_lt_𝓗, H.possible ∧ ↑H.Qrel = Q :=
  let ⟨H', hH'⟩ := exists_possible 𝓒_lt_𝓗 in
  let c : ℝ₊ := ⟨Q / H'.Qrel, div_pos hQ H'.do_rel⟩ in
  let H := c • H' in
  ⟨ H,
    cycle.possible_smul_nonneg (le_of_lt c.property) hH',
    calc ↑H.Qrel
         = Q / H'.Qrel * H'.Qrel : cycle.Qrel_smul_pos c.property
      ...= Q                     : div_mul_cancel _ (ne_of_gt H'.do_rel), ⟩
--

end usual_engine_cycle

/-!
### `usual_pump_cycle`
-/

namespace usual_pump_cycle
variables {𝓒 𝓗 : reservoir} (𝓒_lt_𝓗 : 𝓒 < 𝓗)

/-- There exists a possible `usual_pump_cycle` between any `𝓒 < 𝓗`. -/
axiom exists_possible : ∃ H : usual_pump_cycle 𝓒_lt_𝓗, H.possible

variables {W : ℝ} (hW : 0 < W)
/-- There exists possible `usual_pump_cycle 𝓒_lt_𝓗` that consumes a certain work `W > 0`. -/
lemma exists_psbl_consume : ∃ H : usual_pump_cycle 𝓒_lt_𝓗, H.possible ∧ H.𝓦 = -W :=
  let ⟨H', hH'⟩ := exists_possible 𝓒_lt_𝓗 in
  let c : ℝ₊ := ⟨W /(-H'.𝓦), div_pos hW (neg_pos_of_neg H'.consume_work)⟩ in
  let H := c • H' in
  ⟨ H,
    cycle.possible_smul_nonneg (le_of_lt c.property) hH',
    calc H.𝓦
         = W /(-H'.𝓦) * H'.𝓦 : cycle.𝓦_smul
      ...= (-W)/ H'.𝓦 * H'.𝓦 : by rw [div_neg, ←neg_div]
      ...=  -W                 : div_mul_cancel _ (ne_of_lt H'.consume_work), ⟩
--

end usual_pump_cycle

/-!
## `reversible` `cycle`s

* Since an abstract `cycle` is an equivalence class, that it is reversible means
  that there exists a reversible concrete cycle in these class, such as Carnot cycle.
* Note that a concrete cycle in a reversible-`cycle` eqv class is not neccesarily reversible.
---------------------------------------------------------------------------------------------------/

namespace cycle
variables (H : cycle)

def reversible  := H.possible ∧ (-H).possible
-- def psbl_nonrev := H.possible ∧ ¬(-H).possible

lemma trvial_reversible : (0:cycle).reversible :=
  ⟨trivial_possible, by{rw (@neg_zero cycle _), exact trivial_possible}⟩
lemma reversible_add  {H₁ H₂ : cycle} : H₁.reversible → H₂.reversible → (H₁ + H₂).reversible :=
  assume ⟨h₁psbl, h₁rev⟩ ⟨h₂psbl, h₂rev⟩, by {
  split,
  { exact possible_add h₁psbl h₂psbl, },
  { have : -(H₁ + H₂) = -H₁ + -H₂, rw [neg_add_rev, add_comm], rw this,
    exact possible_add h₁rev h₂rev, } }
lemma reversible_smul_nonneg {c : ℝ} {H : cycle} : 0 ≤ c → H.reversible → (c • H).reversible :=
  assume hc ⟨hpsbl, hrev⟩, by {
  split,
  { exact possible_smul_nonneg hc hpsbl, },
  { have : -(c • H) = c • (-H), rw [smul_neg], rw this,
    exact possible_smul_nonneg hc hrev, } }
--

end cycle

/-!
## Kelvin and Clausius statements
---------------------------------------------------------------------------------------------------/

/-- Kelvin-Plank statement : `one_rsv_cycle` cannot do work. -/
@[reducible] def kelvin_stmt' :=
  ∀ 𝓣, ∀ H : one_rsv_cycle 𝓣, 0 < H.𝓦 → ¬H.possible
/-- Clausius statement : Heat cannot be fully transfered from colder rsv `𝓒` to hotter rsv `𝓗`. -/
@[reducible] def clausius_stmt' :=
  ∀ 𝓒 𝓗, (𝓒 < 𝓗) → ∀ H : abs_rel_cycle 𝓒 𝓗, (H.Qabs:ℝ) = H.Qrel → ¬H.possible
--

theorem kelvin_then_clausius : kelvin_stmt' → clausius_stmt' := by {
  -- `K` < kelvin, `C` < clausius
  assume hKelvin, apply @by_contra clausius_stmt',
  simp only [not_forall, not_not, exists_prop, forall_exists_index, and_imp],
  assume 𝓣 𝓗 𝓣_lt_𝓗, assume CH hCH_Q hCH,
  exact
  let ⟨eng, heng, hQ⟩ := usual_engine_cycle.exists_psbl_abs 𝓣_lt_𝓗 CH.do_rel in
  let KH' := CH.to_cycle + eng.to_cycle in
  let KH : one_rsv_cycle 𝓣 :=
    { one_rsv := by {
        have : KH'.𝓠 = CH.𝓠 + eng.𝓠, from rfl, rw this,
        apply finsupp.support_add_exact,
        { simp only [finset.mem_singleton, ne.def, forall_eq],
          calc CH.𝓠 𝓣 + eng.𝓠 𝓣
               = CH.Qabs  - eng.Qrel : by simp only [CH.Qabs_one_rsv, eng.Qrel_one_rsv,
                                                     sub_neg_eq_add]
            ...= eng.Qabs - eng.Qrel : by simp only [hCH_Q, hQ]
            ...= eng.𝓦              : by rw eng.𝓦_from_Qabs_Qrel
            ...≠ 0                   : ne_of_gt eng.do_work, },
        { have : (CH.𝓠.support ∪ eng.𝓠.support) \ {𝓣} = {𝓗}, {
            rw [CH.two_rsv.elim_left, eng.two_rsv.elim_left],
            ext, simp, split,
              tauto,
              assume this, exact ⟨or.inl this, ne_of_eq_of_ne this eng.two_rsv.elim_right⟩, },
          rw this,
          simp only [finset.mem_singleton, forall_eq],
          calc CH.𝓠 𝓗 + eng.𝓠 𝓗
               = -CH.Qrel + eng.Qabs : by simp only [CH.Qrel_one_rsv, eng.Qabs_one_rsv, neg_neg]
            ...= 0                   : by simp only [hQ, add_left_neg], } },
      ..KH' } in by {
  have : KH.possible, from cycle.possible_add hCH heng,
  refine absurd this (hKelvin _ KH _),
  calc KH.𝓦
       = CH.𝓦             + eng.𝓦 : cycle.𝓦_add
    ...= CH.Qabs - CH.Qrel + eng.𝓦 : by rw CH.𝓦_from_Qabs_Qrel
    ...=                     eng.𝓦 : by simp only [hCH_Q, sub_self, zero_add]
    ...>                     0      : eng.do_work, } }
-- #print axioms kelvin_then_clausius

/-- `reservoir` does not have a minimal element,
    which implies that the absolute zero cannot exist as a `reservoir`. -/
@[reducible] def rsv_no_min' := ∀ 𝓣 : reservoir, ∃ 𝓒, 𝓒 < 𝓣
theorem clausius_then_kelvin : rsv_no_min' → clausius_stmt' → kelvin_stmt' := by {
  -- `K` < kelvin, `C` < clausius
  assume rsv_no_min,
  assume hClausius, apply @by_contra kelvin_stmt',
  simp only [not_forall, not_not, exists_prop, forall_exists_index, and_imp],
  assume 𝓣, assume KH hKH_𝓦 hKH,
  exact
  let ⟨𝓒, 𝓒_lt_𝓣⟩ := rsv_no_min 𝓣 in
  let ⟨pump, hpump, hW⟩ := usual_pump_cycle.exists_psbl_consume 𝓒_lt_𝓣 hKH_𝓦 in
  let CH' := KH.to_cycle + pump.to_cycle in
  have KH_no_𝓒 : KH.𝓠 𝓒 = 0, from by {
    have : 𝓒 ∉ KH.𝓠.support, simp [KH.one_rsv, ne_of_lt 𝓒_lt_𝓣],
    exact (finsupp.not_mem_support_iff).elim_left this, },
  have do_abs_rsv :_ :=
    calc CH'.𝓠 𝓒
         = KH.𝓠 𝓒 + pump.𝓠 𝓒 : rfl
      ...= 0      + pump.Qabs : by rw [KH_no_𝓒, pump.Qabs_one_rsv]
      ...> 0                  : by simp [pump.do_abs],
  have do_rel_rsv :_ :=
    calc CH'.𝓠 𝓣
         = KH.𝓠 𝓣 + pump.𝓠 𝓣   : rfl
      ...= -pump.𝓦 - pump.Qrel : by simp [KH.𝓦_conv_one_rsv, hW, pump.Qrel_one_rsv]
      ...= -pump.Qabs           : by simp [pump.𝓦_from_Qabs_Qrel]
      ...< 0                    : by simp [pump.do_abs],
  let CH : abs_rel_cycle 𝓒 𝓣 :=
    { two_rsv := by {
        refine ⟨_, ne_of_lt 𝓒_lt_𝓣⟩,
        have : CH'.𝓠 = KH.𝓠 + pump.𝓠, from rfl, rw this,
        apply finsupp.support_add_exact,
        { simp only [finset.mem_insert, finset.mem_singleton, ne.def, forall_eq_or_imp, forall_eq],
          split,
            exact ne_of_gt do_abs_rsv,
            exact ne_of_lt do_rel_rsv, },
        { have : (KH.𝓠.support ∪ pump.𝓠.support) \ {𝓒, 𝓣} = ∅, {
            rw [KH.one_rsv, pump.two_rsv.elim_left],
            ext, simp, tauto, },
          rw this,
          simp only [finset.not_mem_empty, is_empty.forall_iff, implies_true_iff], } },
      do_abs_rsv := do_abs_rsv,
      do_rel_rsv := do_rel_rsv,
      ..CH' } in by {
  have : CH.possible, from cycle.possible_add hKH hpump,
  refine absurd this (hClausius _ _ 𝓒_lt_𝓣 CH _),
  suffices : CH.𝓦 = 0, {
    rw CH.𝓦_from_Qabs_Qrel at this,
    exact sub_eq_zero.elim_left this, },
  calc CH.𝓦
       = KH.𝓦 + pump.𝓦 : cycle.𝓦_add
    ...= 0               : by simp only [hW, add_right_neg], } }
-- #print axioms clausius_then_kelvin

/-!
### Axioms of the second law
-/

axiom   kelvin_stmt   :
  ∀ {𝓣}, ∀ H : one_rsv_cycle 𝓣, 0 < H.𝓦 → ¬H.possible
theorem clausius_stmt :
  ∀ {𝓒 𝓗}, (𝓒 < 𝓗) → ∀ H : abs_rel_cycle 𝓒 𝓗, (H.Qabs:ℝ) = H.Qrel → ¬H.possible :=
  kelvin_then_clausius @kelvin_stmt
copy_doc_string kelvin_stmt'   → kelvin_stmt
copy_doc_string clausius_stmt' → clausius_stmt

/-!
## Carnot theorem
---------------------------------------------------------------------------------------------------/

/-- Carnot theorem : reversible `usual_engine_cycle` has the greatest efficiency. -/
@[reducible] def carnot_thm' :=
  ∀ 𝓒 𝓗 (𝓒_lt_𝓗 : 𝓒 < 𝓗), ∀ H C : usual_engine_cycle 𝓒_lt_𝓗,
  H.possible → C.reversible → H.eff ≤ C.eff
theorem clausius_then_carnot : clausius_stmt' → carnot_thm' := by {
  refine forall₃_imp _, assume 𝓒 𝓗 𝓒_lt_𝓗,
  assume hClausius,
  assume H C hH hC,
  by_contradiction heff, rw not_le at heff,
  let c : ℝ₊ :=
    { val := C.𝓦 / H.𝓦,
      property := div_pos C.do_work H.do_work },
  haveI : fact _ := ⟨c.property⟩,
  -- H'
  let H' := c • H,
  have H'𝓦eqC :=
    calc H'.𝓦
         = C.𝓦 / H.𝓦 * H.𝓦 : cycle.𝓦_smul
      ...= C.𝓦               : div_mul_cancel _ (ne_of_gt H.do_work),
  have this : C.eff / H.eff < 1, from (div_lt_one H.eff_pos).elim_right heff,
  have H'Qabs_ltC :=
    calc (H'.Qabs:ℝ)
         = H'.𝓦 / (c.val • H.to_cycle).eff : H'.Qabs_from_𝓦_eff
      ...= C.𝓦 / H.eff                     : by rw [H'𝓦eqC, cycle.eff_smul_pos]
      ...= C.eff / H.eff * C.Qabs           : by rw [C.𝓦_from_eff_Qabs, mul_div_right_comm]
      ...< C.Qabs                           : (mul_lt_iff_lt_one_left C.do_abs).elim_right this,
  have H'Qrel_gtC :=
    calc (H'.Qrel:ℝ)
         = H'.Qabs - H'.𝓦 : H'.Qrel_from_Qabs_𝓦
      ...< C.Qabs  - C.𝓦  : by simp only [H'Qabs_ltC, H'𝓦eqC, sub_lt_sub_iff_right]
      ...= C.Qrel          : C.Qrel_from_Qabs_𝓦.symm,
  -- ClH', `Cl` < clausius
  let ClH' := H'.to_cycle + C.rev.to_cycle,
  have rel𝓗 :=
    calc ClH'.𝓠 𝓗
         = H'.𝓠 𝓗 - C.𝓠 𝓗 : rfl
      ...= H'.Qabs - C.Qabs : by rw [H'.Qabs_one_rsv, C.Qabs_one_rsv]
      ...< 0                : sub_neg.elim_right H'Qabs_ltC,
  have abs𝓒 :=
    calc ClH'.𝓠 𝓒
         = H'.𝓠 𝓒 - C.𝓠 𝓒  : rfl
      ...= C.Qrel - H'.Qrel : by { rw [H'.Qrel_one_rsv, C.Qrel_one_rsv], ring }
      ...> 0                : sub_pos.elim_right H'Qrel_gtC,
  let ClH : abs_rel_cycle 𝓒 𝓗 :=
    { two_rsv := by {
        refine ⟨_, ne_of_lt 𝓒_lt_𝓗⟩,
        have : ClH'.𝓠 = H'.𝓠 + C.rev.𝓠, from rfl, rw this,
        apply finsupp.support_add_exact,
        { simp only [finset.mem_insert, finset.mem_singleton, ne.def, forall_eq_or_imp, forall_eq],
          split,
            exact ne_of_gt abs𝓒,
            exact ne_of_lt rel𝓗, },
        { have : (H'.𝓠.support ∪ C.rev.𝓠.support) \ {𝓒, 𝓗} = ∅, {
            rw [H'.two_rsv.elim_left, C.rev.two_rsv.elim_left],
            ext, simp, },
          simp only [this, finset.not_mem_empty, is_empty.forall_iff, implies_true_iff], } },
      do_abs_rsv := abs𝓒,
      do_rel_rsv := rel𝓗,
      ..ClH' },
  have this :=
    calc ClH.Qabs.val
         = ClH.𝓦                           + ClH.Qrel : ClH.Qabs_from_𝓦_Qrel
      ...= H'.𝓦 + (        -C.to_cycle).𝓦 + ClH.Qrel : by { rw cycle.𝓦_add, refl }
      ...=  C.𝓦 + ((-1:ℝ) • C.to_cycle).𝓦 + ClH.Qrel : by rw [H'𝓦eqC, neg_one_smul]
      ...=                                    ClH.Qrel : by { rw cycle.𝓦_smul, ring },
  refine absurd _ (hClausius ClH this),
  exact cycle.possible_add
    (cycle.possible_smul_nonneg (le_of_lt c.property) hH)
    (hC.elim_right), }
-- #print axioms clausius_then_carnot

/-- There exists a reversible `usual_engine_cycle` between any `𝓒 < 𝓗`. -/
@[reducible] def usual_engine_cycle.exists_reversible' :=
  ∀ 𝓒 𝓗 (𝓒_lt_𝓗 : 𝓒 < 𝓗), ∃ H : usual_engine_cycle 𝓒_lt_𝓗, H.reversible
theorem carnot_then_clausius : usual_engine_cycle.exists_reversible' →
  carnot_thm' → clausius_stmt' := by {
  assume hexists_rev,
  refine forall₃_imp _, assume 𝓒 𝓗 𝓒_lt_𝓗,
  assume hCarnot,
  assume ClH hQ, -- `Cl` < clausius
  by_contradiction hClH,
  exact
  let ⟨C, hC⟩ := hexists_rev _ _ 𝓒_lt_𝓗 in by {
  let c : ℝ₊ :=
    { val := C.Qrel / 2 / ClH.Qabs,
      property := div_pos
        (div_pos C.do_rel zero_lt_two)
        (ClH.do_abs), },
  -- ClH'
  let ClH' := c • ClH,
  have ClH'no𝓦 :=
    calc ClH'.𝓦
         = (↑c • ClH.to_cycle).𝓦 : rfl
      ...= 0 : by{rw [cycle.𝓦_smul, ClH.𝓦_from_Qabs_Qrel, hQ], ring},
  have ClH'abs_ltCrel :=
    calc (ClH'.Qabs:ℝ)
         =                         ClH'.𝓠 𝓒 : ClH'.Qabs_one_rsv
      ...= C.Qrel / 2 / ClH.Qabs *  ClH.𝓠 𝓒 : rfl
      ...= C.Qrel / 2 : by rw [←ClH.Qabs_one_rsv, div_mul_cancel _ (ne_of_gt ClH.do_abs)]
      ...< C.Qrel     : div_lt_self C.do_rel one_lt_two,
  have hQ' :=
    calc (ClH'.Qabs:ℝ)
         = c * ClH.Qabs : cycle.Qabs_smul_pos c.property
      ...= c * ClH.Qrel : by rw hQ
      ...= ClH'.Qrel    : eq.symm $ cycle.Qrel_smul_pos c.property,
  -- CaH', `Ca` < carnot
  let CaH' := ClH'.to_cycle + C.to_cycle,
  have CaH'𝓦eqC : CaH'.𝓦 = C.𝓦, rw [cycle.𝓦_add, ClH'no𝓦, zero_add],
  have rel𝓒 :=
    calc CaH'.𝓠 𝓒
         = ClH'.𝓠 𝓒  + C.𝓠 𝓒 : rfl
      ...= ClH'.Qabs - C.Qrel : by rw [ClH'.Qabs_one_rsv, C.Qrel_one_rsv, sub_neg_eq_add]
      ...< 0                  : sub_neg.elim_right ClH'abs_ltCrel,
  have abs𝓗 :=
    calc CaH'.𝓠 𝓗
         = ClH'.𝓠 𝓗 + C.𝓠 𝓗  : rfl
      ...= -ClH'.Qrel + C.Qabs : by rw [ClH'.Qrel_one_rsv, neg_neg, C.Qabs_one_rsv]
      ...= C.𝓦 + (C.Qrel - ClH'.Qabs) : by{rw [hQ', C.Qabs_from_𝓦_Qrel], ring}
      ...>         C.Qrel - ClH'.Qabs  : (lt_add_iff_pos_left _).elim_right C.do_work
      ...> 0                           : sub_pos.elim_right ClH'abs_ltCrel,
  let CaH : usual_engine_cycle 𝓒_lt_𝓗 :=
    { two_rsv := by {
        refine ⟨_, ne_of_gt 𝓒_lt_𝓗⟩,
        have : CaH'.𝓠 = ClH'.𝓠 + C.𝓠, from rfl, rw this,
        apply finsupp.support_add_exact,
        { simp only [finset.mem_insert, finset.mem_singleton, ne.def, forall_eq_or_imp, forall_eq],
          split,
            exact ne_of_gt abs𝓗,
            exact ne_of_lt rel𝓒, },
        { have : (ClH'.𝓠.support ∪ C.𝓠.support) \ {𝓗, 𝓒} = ∅, {
            rw [ClH'.two_rsv.elim_left, C.two_rsv.elim_left],
            ext, simp, },
          simp only [this, finset.not_mem_empty, is_empty.forall_iff, implies_true_iff], } },
      do_abs_rsv := abs𝓗,
      do_rel_rsv := rel𝓒,
      do_work :=
        calc CaH'.𝓦
             = C.𝓦 : CaH'𝓦eqC
          ...> 0    : C.do_work,
      ..CaH' },
  have :=
    calc (CaH.Qabs:ℝ)
         = ClH'.𝓠 𝓗 + C.𝓠 𝓗 : by { rw CaH.Qabs_one_rsv, refl }
      ...= C.Qabs - ClH'.Qrel : by { rw [C.Qabs_one_rsv, ClH'.Qrel_one_rsv], ring }
      ...< C.Qabs             : sub_lt_self _ ClH'.do_rel,
  have :=
    calc CaH.eff
         = CaH.𝓦 / CaH.Qabs : rfl
      ...> C.𝓦 / C.Qabs : by { rw CaH'𝓦eqC, exact div_lt_div_of_lt_left C.do_work CaH.do_abs this}
      ...= C.eff         : rfl,
  refine absurd (hCarnot CaH C _ hC) (not_le_of_gt this),
  exact cycle.possible_add
    (cycle.possible_smul_nonneg (le_of_lt c.property) hClH)
    (hC.elim_left), } }
-- #print axioms carnot_then_clausius

section carnot_thm
variables {𝓒 𝓗 : reservoir} {𝓒_lt_𝓗 : 𝓒 < 𝓗} {H C : usual_engine_cycle 𝓒_lt_𝓗}

theorem carnot_thm : H.possible → C.reversible → H.eff ≤ C.eff :=
  (clausius_then_carnot @clausius_stmt) _ _ 𝓒_lt_𝓗 H C
copy_doc_string carnot_thm' → carnot_thm
/-- An `usual_engine_cycle` is reversible iff it has the greatest efficiency. -/
theorem usual_engine_cycle.rev_iff_eff (hC : C.reversible) : H.reversible ↔ H.eff = C.eff := by {
  split,
  { assume hH,
    have H_le_C := carnot_thm hH.elim_left hC,
    have C_le_H := carnot_thm hC.elim_left hH,
    exact eq_of_le_of_not_lt H_le_C (not_lt_of_ge C_le_H), },
  { assume heff,
    exact let ⟨c, hc⟩ := usual_engine_cycle.eq_smul_pos_of_eff_eq heff in by {
      rw hc,
      exact cycle.reversible_smul_nonneg (le_of_lt c.property) hC, } } }
--

end carnot_thm

end thermodynamics


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

import category_theory.equivalence

/-! Tools for compatibilities between Dold-Kan equivalences

The purpose of this file is to introduce tools which will enable the
construction of the Dold-Kan equivalence `simplicial_object C ≌ chain_complex C ℕ`
for a pseudoabelian category `C` from the equivalence
`karoubi (simplicial_object C) ≌ karoubi (chain_complex C ℕ)` and the two
equivalences `simplicial_object C ≅ karoubi (simplicial_object C)` and
`chain_complex C ℕ ≅ karoubi (chain_complex C ℕ)`.

It is certainly possible to get an equivalence `simplicial_object C ≌ chain_complex C ℕ`
using a compositions of the three equivalences above, but then neither the functor
nor the inverse would have good definitional properties. For example, it would be better
if the inverse functor of the equivalence was the functor
`Γ₀ : simplicial_object C ⥤ chain_complex C ℕ` which was constructed in `functor_gamma.lean`.

In this file, given four categories `A`, `A'`, `B`, `B'`, equivalences `eA : A ≅ A'`,
`eB : B ≅ B'`, `e' : A' ≅ B'`, functors `F : A ⥤ B'`, `G : B ⥤ A` equipped with certain
compatibilities, we construct successive equivalences:
- `equivalence₀` from `A` to `B'`, which is the composition of `eA` and `e'`.
- `equivalence₁` from `A` to `B'`, with the same inverse functor as `equivalence₀`,
but whose functor is `F`.
- `equivalence₂` from `A` to `B`, which is the composition of `equivalence₁` and the
inverse of `eB`:
- `equivalence` from `A` to `B`, which has the same functor `F ⋙ eB.inverse` as `equivalence₂`,
but whose inverse functor is `G`.

When extra assumptions are given, we also provide simplification lemmas for the
unit and counit isomorphisms of `equivalence`.

-/

open category_theory category_theory.category

namespace algebraic_topology

namespace dold_kan

namespace compatibility

variables {A A' B B' : Type*} [category A] [category A'] [category B] [category B']
  (eA : A ≌ A') (eB : B ≌ B') (e' : A' ≌ B')
  {F : A ⥤ B'} (hF : eA.functor ⋙ e'.functor ≅ F)
  {G : B ⥤ A} (hG : eB.functor ⋙ e'.inverse ≅ G ⋙ eA.functor)

/-- A basic equivalence `A ≅ B'` obtained by composing `eA : A ≅ A'` and `e' : A' ≅ B'`. -/
def equivalence₀ : A ≌ B' := eA.trans e'

lemma equivalence₀_functor : (equivalence₀ eA e').functor = eA.functor ⋙ e'.functor := rfl
lemma equivalence₀_inverse : (equivalence₀ eA e').inverse = e'.inverse ⋙ eA.inverse := rfl

include hF
variables {eA} {e'}

/-- An intermediate equivalence `A ≅ B'` whose functor is `F` and whose inverse is
`e'.inverse ⋙ eA.inverse`. -/
def equivalence₁ : A ≌ B' :=
begin
  letI : is_equivalence F :=
    is_equivalence.of_iso hF (is_equivalence.of_equivalence (equivalence₀ eA e')),
  exact F.as_equivalence,
end

lemma equivalence₁_functor : (equivalence₁ hF).functor = F := rfl
lemma equivalence₁_inverse : (equivalence₁ hF).inverse = e'.inverse ⋙ eA.inverse := rfl

/-- The counit isomorphism of the equivalence `equivalence₁` between `A` and `B'`. -/
@[simps]
def equivalence₁_counit_iso :
  (e'.inverse ⋙ eA.inverse) ⋙ F ≅ 𝟭 B' :=
calc (e'.inverse ⋙ eA.inverse) ⋙ F
  ≅ (e'.inverse ⋙ eA.inverse) ⋙ (eA.functor ⋙ e'.functor) : iso_whisker_left _ hF.symm
... ≅ e'.inverse ⋙ (eA.inverse ⋙ eA.functor) ⋙ e'.functor : iso.refl _
... ≅ e'.inverse ⋙ 𝟭 _ ⋙ e'.functor : iso_whisker_left _ (iso_whisker_right eA.counit_iso _)
... ≅ e'.inverse ⋙ e'.functor : iso.refl _
... ≅ 𝟭 B' : e'.counit_iso

lemma equivalence₁_counit_iso_eq : (equivalence₁ hF).counit_iso = equivalence₁_counit_iso hF :=
begin
  ext Y',
  dsimp [equivalence₀, equivalence₁, equivalence₁_counit_iso, nat_iso.hcomp,
    is_equivalence.inverse, is_equivalence.of_equivalence],
  simp only [category_theory.functor.map_id, comp_id, assoc],
end

/-- The unit isomorphism of the equivalence `equivalence₁` between `A` and `B'`. -/
@[simps]
def equivalence₁_unit_iso :
  𝟭 A ≅ F ⋙ (e'.inverse ⋙ eA.inverse) :=
calc 𝟭 A ≅ eA.functor ⋙ eA.inverse : eA.unit_iso
... ≅ eA.functor ⋙ 𝟭 A' ⋙ eA.inverse : iso.refl _
... ≅ eA.functor ⋙ (e'.functor ⋙ e'.inverse) ⋙ eA.inverse :
  iso_whisker_left _ (iso_whisker_right e'.unit_iso _)
... ≅ (eA.functor ⋙ e'.functor) ⋙ (e'.inverse ⋙ eA.inverse) : iso.refl _
... ≅ F ⋙ (e'.inverse ⋙ eA.inverse) : iso_whisker_right hF _

lemma equivalence₁_unit_iso_eq : (equivalence₁ hF).unit_iso = equivalence₁_unit_iso hF :=
begin
  ext X,
  dsimp [equivalence₀, equivalence₁, equivalence₁_unit_iso, nat_iso.hcomp,
    is_equivalence.of_equivalence],
  simp only [id_comp, comp_id],
end

include eB

/-- An intermediate equivalence `A ≅ B` obtained as the composition of `equivalence₁` and
the inverse of `eB : B ≌ B'`. -/
def equivalence₂ : A ≌ B := (equivalence₁ hF).trans eB.symm

lemma equivalence₂_functor : (equivalence₂ eB hF).functor = F ⋙ eB.inverse := rfl
lemma equivalence₂_inverse : (equivalence₂ eB hF).inverse =
  eB.functor ⋙ e'.inverse ⋙ eA.inverse := rfl

/-- The counit isomorphism of the equivalence `equivalence₂` between `A` and `B`. -/
@[simps]
def equivalence₂_counit_iso :
  (eB.functor ⋙ e'.inverse ⋙ eA.inverse) ⋙ (F ⋙ eB.inverse) ≅ 𝟭 B :=
begin
  calc (eB.functor ⋙ e'.inverse ⋙ eA.inverse) ⋙ (F ⋙ eB.inverse)
    ≅ eB.functor ⋙ (e'.inverse ⋙ eA.inverse ⋙ F) ⋙ eB.inverse : by refl
  ... ≅ eB.functor ⋙ 𝟭 _ ⋙ eB.inverse :
    iso_whisker_left _ (iso_whisker_right (equivalence₁_counit_iso hF) _)
  ... ≅ eB.functor ⋙ eB.inverse : by refl
  ... ≅ 𝟭 B : eB.unit_iso.symm,
end

lemma equivalence₂_counit_iso_eq :
  (equivalence₂ eB hF).counit_iso = equivalence₂_counit_iso eB hF :=
begin
  ext Y',
  dsimp [equivalence₂, equivalence₂_counit_iso, iso.refl],
  erw [equivalence₁_counit_iso_eq, nat_trans.id_app, id_comp, comp_id],
end

/-- The unit isomorphism of the equivalence `equivalence₂` between `A` and `B`. -/
@[simps]
def equivalence₂_unit_iso :
  𝟭 A ≅ (F ⋙ eB.inverse) ⋙ (eB.functor ⋙ e'.inverse ⋙ eA.inverse) :=
calc 𝟭 A ≅ F ⋙ e'.inverse ⋙ eA.inverse : equivalence₁_unit_iso hF
... ≅ F ⋙ 𝟭 B' ⋙ (e'.inverse ⋙ eA.inverse) : iso.refl _
... ≅ F ⋙ (eB.inverse ⋙ eB.functor) ⋙ e'.inverse ⋙ eA.inverse :
  iso_whisker_left _ (iso_whisker_right eB.counit_iso.symm _)
... ≅ (F ⋙ eB.inverse) ⋙ (eB.functor ⋙ e'.inverse ⋙ eA.inverse) : iso.refl _

lemma equivalence₂_unit_iso_eq :
  (equivalence₂ eB hF).unit_iso = equivalence₂_unit_iso eB hF :=
begin
  ext X,
  dsimp [equivalence₂, equivalence₂_unit_iso],
  erw equivalence₁_unit_iso_eq,
  simpa only [assoc, comp_id, nat_iso.cancel_nat_iso_hom_left],
end

variable {eB}
include hG

/-- The equivalence `A ≅ B` whose functor is `F ⋙ eB.inverse` and
whose inverse is `G : B ≅ A`. -/
def equivalence : A ≌ B :=
begin
  letI : is_equivalence G := begin
    refine is_equivalence.of_iso _ (is_equivalence.of_equivalence (equivalence₂ eB hF).symm),
    calc eB.functor ⋙ e'.inverse ⋙ eA.inverse
      ≅ (eB.functor ⋙ e'.inverse) ⋙ eA.inverse : iso.refl _
    ... ≅ (G ⋙ eA.functor) ⋙ eA.inverse : iso_whisker_right hG _
    ... ≅ G ⋙ 𝟭 A : iso_whisker_left _ eA.unit_iso.symm
    ... ≅ G : functor.right_unitor G,
  end,
  exact G.as_equivalence.symm,
end

lemma equivalence_functor : (equivalence hF hG).functor = F ⋙ eB.inverse := rfl
lemma equivalence_inverse : (equivalence hF hG).inverse = G := rfl

omit hG hF

/-- The isomorphism `eB.functor ⋙ e'.inverse ⋙ e'.functor ≅ eB.functor` deduced
from the counit isomorphism of `e'`. -/
@[simps hom_app]
def τ₀ : eB.functor ⋙ e'.inverse ⋙ e'.functor ≅ eB.functor :=
calc eB.functor ⋙ e'.inverse ⋙ e'.functor
  ≅ eB.functor ⋙ 𝟭 _ : iso_whisker_left _ e'.counit_iso
... ≅ eB.functor : functor.right_unitor _

include hF hG

/-- The isomorphism `eB.functor ⋙ e'.inverse ⋙ e'.functor ≅ eB.functor` deduced
the isomorphisms `hF : eA.functor ⋙ e'.functor ≅ F`,
`hG : eB.functor ⋙ e'.inverse ≅ G ⋙ eA.functor` and the datum of
an isomorphism `η : G ⋙ F ≅ eB.functor`. -/
@[simps hom_app]
def τ₁ (η : G ⋙ F ≅ eB.functor) :
  eB.functor ⋙ e'.inverse ⋙ e'.functor ≅ eB.functor :=
calc eB.functor ⋙ e'.inverse ⋙ e'.functor
  ≅ (eB.functor ⋙ e'.inverse) ⋙ e'.functor : iso.refl _
... ≅ (G ⋙ eA.functor) ⋙ e'.functor : iso_whisker_right hG _
... ≅ G ⋙ (eA.functor ⋙ e'.functor) : by refl
... ≅ G ⋙ F : iso_whisker_left _ hF
... ≅ eB.functor : η

variables (η : G ⋙ F ≅ eB.functor) (hη : τ₀ = τ₁ hF hG η)

omit hF hG
include η

/-- The counit isomorphism of `equivalence`. -/
@[simps]
def equivalence_counit_iso : G ⋙ (F ⋙ eB.inverse) ≅ 𝟭 B :=
calc G ⋙ (F ⋙ eB.inverse) ≅ (G ⋙ F) ⋙ eB.inverse : iso.refl _
... ≅ eB.functor ⋙ eB.inverse : iso_whisker_right η _
... ≅ 𝟭 B : eB.unit_iso.symm

variables {η hF hG}
include hη

lemma equivalence_counit_iso_eq :
  (equivalence hF hG).counit_iso = equivalence_counit_iso η :=
begin
  ext1, apply nat_trans.ext, ext Y,
  dsimp [equivalence, equivalence_counit_iso, is_equivalence.of_equivalence],
  simp only [equivalence₂_counit_iso_eq eB hF],
  erw [nat_trans.id_app, nat_trans.id_app],
  dsimp [equivalence₂, equivalence₁],
  simp only [assoc, comp_id, F.map_id, id_comp,
    equivalence₂_counit_iso_hom_app, ← eB.inverse.map_comp_assoc,
    ← τ₀_hom_app, hη, τ₁_hom_app],
  erw hF.inv.naturality_assoc,
  congr' 2,
  dsimp,
  simp only [assoc, ← e'.functor.map_comp_assoc, eA.functor.map_comp,
    equivalence.fun_inv_map, iso.inv_hom_id_app_assoc, hG.inv_hom_id_app],
  dsimp,
  rw [comp_id, eA.functor_unit_iso_comp, e'.functor.map_id, id_comp, hF.inv_hom_id_app_assoc],
end

omit hη η eB
include hF

variable (hF)

/-- The isomorphism `eA.functor ≅ F ⋙ e'.inverse` deduced from the
unit isomorphism of `e'` and the isomorphism `hF : eA.functor ⋙ e'.functor ≅ F`. -/
@[simps]
def υ : eA.functor ≅ F ⋙ e'.inverse :=
calc eA.functor ≅ eA.functor ⋙ 𝟭 A' : (functor.left_unitor _).symm
... ≅ eA.functor ⋙ (e'.functor ⋙ e'.inverse) : iso_whisker_left _ e'.unit_iso
... ≅ (eA.functor ⋙ e'.functor) ⋙ e'.inverse : iso.refl _
... ≅ F ⋙ e'.inverse : iso_whisker_right hF _

variables (ε : eA.functor ≅ F ⋙ e'.inverse) (hε : υ hF = ε)

include ε hG
omit hF

variable (hG)

/-- The unit isomorphism of `equivalence`. -/
@[simps]
def equivalence_unit_iso : 𝟭 A ≅ (F ⋙ eB.inverse) ⋙ G :=
calc 𝟭 A ≅ eA.functor ⋙ eA.inverse : eA.unit_iso
... ≅ (F ⋙ e'.inverse) ⋙ eA.inverse : iso_whisker_right ε _
... ≅ F ⋙ 𝟭 B' ⋙ e'.inverse ⋙ eA.inverse : iso.refl _
... ≅ F ⋙ (eB.inverse ⋙ eB.functor) ⋙ (e'.inverse ⋙ eA.inverse) :
      iso_whisker_left _ (iso_whisker_right eB.counit_iso.symm _)
... ≅ (F ⋙ eB.inverse) ⋙ (eB.functor ⋙ e'.inverse) ⋙ eA.inverse : iso.refl _
... ≅ (F ⋙ eB.inverse) ⋙ (G ⋙ eA.functor) ⋙ eA.inverse :
      iso_whisker_left _ (iso_whisker_right hG _)
... ≅ (F ⋙ eB.inverse ⋙ G) ⋙ (eA.functor ⋙ eA.inverse) : iso.refl _
... ≅ (F ⋙ eB.inverse ⋙ G) ⋙ 𝟭 A : iso_whisker_left _ eA.unit_iso.symm
... ≅ (F ⋙ eB.inverse) ⋙ G : iso.refl _

include hε
variables {ε hF hG}

lemma equivalence_unit_iso_eq :
  (equivalence hF hG).unit_iso = equivalence_unit_iso hG ε :=
begin
  ext1, apply nat_trans.ext, ext X,
  dsimp [equivalence, iso.refl, nat_iso.hcomp, is_equivalence.inverse,
    is_equivalence.of_equivalence],
  erw [nat_trans.id_app, id_comp, G.map_id, comp_id, comp_id],
  simp only [equivalence₂_unit_iso_eq eB hF, equivalence₂_unit_iso_hom_app],
  dsimp [equivalence₂, equivalence₁],
  simp only [assoc, equivalence_unit_iso_hom_app, nat_iso.cancel_nat_iso_hom_left,
    ← eA.inverse.map_comp_assoc, ← hε, υ_hom_app],
end

end compatibility

end dold_kan

end algebraic_topology


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
-/
import Mathlib.Init.SetNotation
import Mathlib.Init.Logic
import Mathlib.Tactic.Lint

open Decidable List

universe u v w

instance (α : Type u) : Inhabited (List α) :=
  ⟨List.nil⟩

variable {α : Type u} {β : Type v} {γ : Type w}

namespace List

attribute [simp] get! get? head? headD head tail! tail? tailD getLast! getLast?
  getLastD reverseAux eraseIdx isEmpty map map₂ join filterMap dropWhile find? findSome?
  replace elem lookup drop take takeWhile foldr zipWith unzip rangeAux enumFrom init
  intersperse isPrefixOf isEqv dropLast

@[simp] lemma get_cons_zero {as : List α} : (a :: as).get ⟨0, id <| Nat.zero_lt_succ _⟩ = a := rfl
@[simp] lemma get_cons_succ {as : List α} {h : i + 1 < (a :: as).length} :
  (a :: as).get ⟨i+1, h⟩ = as.get ⟨i, Nat.lt_of_succ_lt_succ h⟩ := rfl

@[simp] lemma getLast_singleton {x : α} : [x].getLast (id (by simp)) = x := rfl
@[simp] lemma getLast_cons_cons {x : α} : (x::y::ys).getLast (id (by simp)) = (y::ys).getLast (by simp) := rfl

-- The `id <|` above is a workaround to allow Lean to unify get_cons_zero's lhs
-- in reducible transparency:
example {as : List α} {h} : (a :: as).get ⟨0, h⟩ = a := by simp

attribute [simp] iota

@[simp] theorem not_mem_nil (a : α) : ¬ a ∈ [] := fun.

@[simp] theorem mem_cons {a b : α} {l : List α} :
  a ∈ (b :: l) ↔ a = b ∨ a ∈ l :=
  ⟨fun h => by cases h <;> simp [Membership.mem, *],
   fun | Or.inl rfl => by constructor | Or.inr h => by constructor; assumption⟩

protected def bagInter {α} [BEq α] : List α → List α → List α
| [], _ => []
| _, [] => []
| a :: l₁, l₂ => if l₂.elem a then a :: List.bagInter l₁ (l₂.erase a) else List.bagInter l₁ l₂

protected def diff {α} [BEq α] : List α → List α → List α
| l, [] => l
| l₁, a :: l₂ => if l₁.elem a then List.diff (l₁.erase a) l₂ else List.diff l₁ l₂

open Option Nat

/-- Get the tail of a nonempty list, or return `[]` for `[]`. -/
def tail : List α → List α
| []    => []
| a::as => as

def mapIdxAux (f : Nat → α → β) : Nat → List α → List β
| k, [] => []
| k, a :: as => f k a :: mapIdxAux f (k+1) as

/-- Given a function `f : Nat → α → β` and `as : list α`, `as = [a₀, a₁, ...]`, returns the list
`[f 0 a₀, f 1 a₁, ...]`. -/
def mapIdx (f : Nat → α → β) (as : List α) : List β :=
  mapIdxAux f 0 as

/-- Applicative variant of `mapIdx`. -/
def mapIdxM {m : Type v → Type w} [Applicative m] (as : List α) (f : Nat → α → m β) :
  m (List β) :=
  let rec loop : Nat → List α → m (List β)
  | _,  [] => pure []
  | n, a :: as => List.cons <$> f n a <*> loop (n + 1) as
  loop 0 as

/-- `after p xs` is the suffix of `xs` after the first element that satisfies
  `p`, not including that element.
  ```lean
  after      (eq 1)       [0, 1, 2, 3] = [2, 3]
  drop_while (not ∘ eq 1) [0, 1, 2, 3] = [1, 2, 3]
  ```
-/
def after (p : α → Prop) [DecidablePred p] : List α → List α
| [] => []
| x :: xs => if p x then xs else after p xs

def findIdx (p : α → Prop) [DecidablePred p] : List α → Nat
| [] => 0
| a :: l => if p a then 0 else succ (findIdx p l)

def indexOf [BEq α] (a : α) : List α → Nat := findIdx (a == ·)

@[simp] def removeNth : List α → Nat → List α
| [], _ => []
| x :: xs, 0 => xs
| x :: xs, i+1 => x :: removeNth xs i

def bor (l : List Bool) : Bool := any l id

def band (l : List Bool) : Bool := all l id

-- TODO(Mario): restore `protected` when general `insert` is added
def insert [DecidableEq α] (a : α) (l : List α) : List α :=
  if a ∈ l then l else a :: l

protected def union [DecidableEq α] (l₁ l₂ : List α) : List α :=
  foldr insert l₂ l₁

instance [DecidableEq α] : Union (List α) :=
  ⟨List.union⟩

protected def inter [DecidableEq α] (l₁ l₂ : List α) : List α :=
  filter (· ∈ l₂) l₁

instance [DecidableEq α] : Inter (List α) := ⟨List.inter⟩

@[simp] def repeat' (a : α) : Nat → List α
| 0 => []
| succ n => a :: repeat' a n

def last! [Inhabited α] : List α → α
| [] => panic! "empty list"
| [a] => a
| [a, b] => b
| a :: b :: l => last! l


import Logic.Predicate.FirstOrder.Language
import Logic.Predicate.Coding

universe u v

namespace FirstOrder

open SubFormula
variable {L : Language.{u}} [∀ k, DecidableEq (L.func k)] [∀ k, DecidableEq (L.rel k)]

def shifts (Δ : Finset (SyntacticSubFormula L n)) :
  Finset (SyntacticSubFormula L n) := Δ.map shiftEmb

lemma shifts_eq_image (Δ : Finset (SyntacticSubFormula L n)) : shifts Δ = Δ.image shift := Finset.map_eq_image _ _

@[simp] lemma mem_shifts_iff (p : SyntacticSubFormula L n) (Δ : Finset (SyntacticSubFormula L n)) :
    shift p ∈ shifts Δ ↔ p ∈ Δ :=
  Finset.mem_map' _

@[simp] lemma shifts_ss (Δ Γ : Finset (SyntacticSubFormula L n)) :
    shifts Δ ⊆ shifts Γ ↔ Δ ⊆ Γ := Finset.map_subset_map

lemma shifts_insert (p : SyntacticSubFormula L n) (Δ : Finset (SyntacticSubFormula L n)) :
    shifts (insert p Δ) = insert (shift p) (shifts Δ) :=
  by simp[shifts, shiftEmb_eq_shift]

inductive Derivation : Finset (SyntacticFormula L) → Type _
| axL     : ∀ (Δ : Finset (SyntacticFormula L)) {k} (r : L.rel k) (v : Fin k → SyntacticTerm L),
    rel r v ∈ Δ → nrel r v ∈ Δ → Derivation Δ
| verum   : ∀ (Δ : Finset (SyntacticFormula L)), ⊤ ∈ Δ → Derivation Δ
| orLeft  : ∀ (Δ : Finset (SyntacticFormula L)) (p q : SyntacticFormula L),
    Derivation (insert p Δ) → Derivation (insert (p ⋎ q) Δ)
| orRight : ∀ (Δ : Finset (SyntacticFormula L)) (p q : SyntacticFormula L),
    Derivation (insert q Δ) → Derivation (insert (p ⋎ q) Δ)
| and     : ∀ (Δ : Finset (SyntacticFormula L)) (p q : SyntacticFormula L),
    Derivation (insert p Δ) → Derivation (insert q Δ) → Derivation (insert (p ⋏ q) Δ)
| all     : ∀ (Δ : Finset (SyntacticFormula L)) (p : SyntacticSubFormula L 1),
    Derivation (insert (free p) (shifts Δ)) → Derivation (insert (∀' p) Δ)
| ex      : ∀ (Δ : Finset (SyntacticFormula L)) (t : SyntacticTerm L) (p : SyntacticSubFormula L 1),
    Derivation (insert (subst t p) Δ) → Derivation (insert (∃' p) Δ)

instance : HasVdash (Finset (SyntacticFormula L)) (Type u) := ⟨Derivation⟩

abbrev DerivationList (G : List (SyntacticFormula L)) := ⊩ G.toFinset

abbrev Derivation.Valid (p : SyntacticFormula L) := ⊩ ({p} : Finset _)

structure Proof (T : CTheory L) (σ : Sentence L) where
  leftHand : Finset (Sentence L)
  hleftHand : ↑leftHand ⊆ SubFormula.neg '' T
  derivation : ⊩ ((insert σ leftHand).image emb : Finset (SyntacticFormula L))

instance : HasTurnstile (Sentence L) (Type u) := ⟨Proof⟩

namespace Derivation
variable {Δ Γ : Finset (SyntacticFormula L)}

section Repr
variable [∀ k, ToString (L.func k)] [∀ k, ToString (L.rel k)]

protected unsafe def repr : {Δ : Finset (SyntacticFormula L)} → Derivation Δ → String
  | _, axL Δ _ _ _ _   =>
      "\\AxiomC{}\n" ++
      "\\RightLabel{\\scriptsize(axL)}\n" ++
      "\\UnaryInfC{$" ++ reprStr Δ ++ "$}\n\n"
  | _, verum Δ _       =>
      "\\AxiomC{}\n" ++
      "\\RightLabel{\\scriptsize($\\top$)}\n" ++
      "\\UnaryInfC{$" ++ reprStr Δ ++ "$}\n\n"
  | _, orLeft Δ p q d  =>
      d.repr ++
      "\\RightLabel{\\scriptsize($\\lor$L)}\n" ++
      "\\UnaryInfC{$" ++ reprStr (insert (p ⋎ q) Δ) ++ "$}\n\n"
  | _, orRight Δ p q d =>
      d.repr ++
      "\\RightLabel{\\scriptsize($\\lor$R)}\n" ++
      "\\UnaryInfC{$" ++ reprStr (insert (p ⋎ q) Δ) ++ "$}\n\n"
  | _, and Δ p q dp dq =>
      dp.repr ++
      dq.repr ++
      "\\RightLabel{\\scriptsize($\\land$)}\n" ++
      "\\BinaryInfC{$" ++ reprStr (insert (p ⋏ q) Δ) ++ "$}\n\n"
  | _, all Δ p d       =>
      d.repr ++
      "\\RightLabel{\\scriptsize($\\forall$)}\n" ++
      "\\UnaryInfC{$" ++ reprStr (insert (∀' p) Δ) ++ "$}\n\n"
  | _, ex Δ _ p d      =>
      d.repr ++
      "\\RightLabel{\\scriptsize($\\exists$)}\n" ++
      "\\UnaryInfC{$" ++ reprStr (insert (∃' p) Δ) ++ "$}\n\n"

unsafe instance : Repr (⊩ Δ) where
  reprPrec d _ := d.repr

protected def toStr : {Δ : Finset (SyntacticFormula L)} → Derivation Δ → String
  | _, axL _ r v _ _   =>
      "\\AxiomC{}\n" ++
      "\\RightLabel{\\scriptsize(axL)}\n" ++
      "\\UnaryInfC{$" ++ toString (rel r v) ++ "," ++ toString (nrel r v) ++ ", ... $}\n\n"
  | _, verum _ _       =>
      "\\AxiomC{}\n" ++
      "\\RightLabel{\\scriptsize($\\top$)}\n" ++
      "\\UnaryInfC{$ ⊤, ... $}\n\n"
  | _, orLeft _ p q d  =>
      d.toStr ++
      "\\RightLabel{\\scriptsize($\\lor$L)}\n" ++
      "\\UnaryInfC{$" ++ toString (p ⋎ q) ++ ", ... $}\n\n"
  | _, orRight _ p q d =>
      d.toStr ++
      "\\RightLabel{\\scriptsize($\\lor$R)}\n" ++
      "\\UnaryInfC{$" ++ toString (p ⋎ q) ++ ", ... $}\n\n"
  | _, and _ p q dp dq =>
      dp.toStr ++
      dq.toStr ++
      "\\RightLabel{\\scriptsize($\\land$)}\n" ++
      "\\BinaryInfC{$" ++ toString (p ⋏ q) ++ ", ... $}\n\n"
  | _, all _ p d       =>
      d.toStr ++
      "\\RightLabel{\\scriptsize($\\forall$)}\n" ++
      "\\UnaryInfC{$" ++ toString (∀' p) ++ ", ... $}\n\n"
  | _, ex _ _ p d      =>
      d.toStr ++
      "\\RightLabel{\\scriptsize($\\exists$)}\n" ++
      "\\UnaryInfC{$" ++ toString (∃' p) ++ ", ... $}\n\n"

protected def toStrCompact : {Δ : Finset (SyntacticFormula L)} → Derivation Δ → String
  | _, axL _ _ _ _ _   =>
      "\\AxiomC{}\n" ++
      "\\RightLabel{\\scriptsize(axL)}\n" ++
      "\\UnaryInfC{}\n\n"
  | _, verum _ _       =>
      "\\AxiomC{}\n" ++
      "\\RightLabel{\\scriptsize($\\top$)}\n" ++
      "\\UnaryInfC{}\n\n"
  | _, orLeft _ _ _ d  =>
      d.toStrCompact ++
      "\\RightLabel{\\scriptsize($\\lor$L)}\n" ++
      "\\UnaryInfC{}\n\n"
  | _, orRight _ _ _ d =>
      d.toStrCompact ++
      "\\RightLabel{\\scriptsize($\\lor$R)}\n" ++
      "\\UnaryInfC{}\n\n"
  | _, and _ _ _ dp dq =>
      dp.toStrCompact ++
      dq.toStrCompact ++
      "\\RightLabel{\\scriptsize($\\land$)}\n" ++
      "\\BinaryInfC{}\n\n"
  | _, all _ _ d       =>
      d.toStrCompact ++
      "\\RightLabel{\\scriptsize($\\forall$)}\n" ++
      "\\UnaryInfC{}\n\n"
  | _, ex _ _ _ d      =>
      d.toStrCompact ++
      "\\RightLabel{\\scriptsize($\\exists$)}\n" ++
      "\\UnaryInfC{}\n\n"

instance : ToString (⊩ Δ) := ⟨Derivation.toStr⟩

end Repr

protected def cast (d : Derivation Δ) (e : Δ = Γ) : ⊩ Γ := cast (by simp[HasVdash.vdash, e]) d

def weakening : ∀ {Δ}, ⊩ Δ → ∀ {Γ : Finset (SyntacticFormula L)}, Δ ⊆ Γ → ⊩ Γ
  | _, axL Δ r v hrel hnrel, Γ, h => axL Γ r v (h hrel) (h hnrel)
  | _, verum Δ htop,         Γ, h => verum Γ (h htop)
  | _, orLeft Δ p q d,       Γ, h =>
      have : ⊩ insert p Γ := weakening d (Finset.insert_subset_insert p (Finset.insert_subset.mp h).2)
      have : ⊩ insert (p ⋎ q) Γ := orLeft Γ p q this
      this.cast (by simp; exact (Finset.insert_subset.mp h).1)
  | _, orRight Δ p q d,      Γ, h =>
      have : ⊩ insert q Γ := weakening d (Finset.insert_subset_insert q (Finset.insert_subset.mp h).2)
      have : ⊩ insert (p ⋎ q) Γ := orRight Γ p q this
      this.cast (by simp; exact (Finset.insert_subset.mp h).1)
  | _, and Δ p q dp dq,      Γ, h =>
      have dp : ⊩ insert p Γ := weakening dp (Finset.insert_subset_insert p (Finset.insert_subset.mp h).2)
      have dq : ⊩ insert q Γ := weakening dq (Finset.insert_subset_insert q (Finset.insert_subset.mp h).2)
      have : ⊩ insert (p ⋏ q) Γ := and Γ p q dp dq
      Derivation.cast this (by simp; exact (Finset.insert_subset.mp h).1)
  | _, all Δ p d,            Γ, h =>
      have : ⊩ insert (free p) (shifts Γ) := weakening d (Finset.insert_subset_insert _ $ by simpa using (Finset.insert_subset.mp h).2)
      have : ⊩ insert (∀' p) Γ := all Γ p this
      Derivation.cast this (by simp; exact (Finset.insert_subset.mp h).1)
  | _, ex Δ t p d,           Γ, h =>
      have : ⊩ insert (subst t p) Γ := weakening d (Finset.insert_subset_insert _ $ by simpa using (Finset.insert_subset.mp h).2)
      have : ⊩ insert (∃' p) Γ := ex Γ t p this
      Derivation.cast this (by simp; exact (Finset.insert_subset.mp h).1)

--def or' {p q : SyntacticFormula L} (h : p ⋎ q ∈ Δ) (d : ⊩ insert p Δ) : ⊩ Δ :=
--  weakening (or Δ p q d) (by simp[Finset.insert_subset, h])

def orLeft' {p q : SyntacticFormula L} (h : p ⋎ q ∈ Δ) (d : ⊩ insert p (Δ.erase (p ⋎ q))) : ⊩ Δ :=
  (orLeft _ p q d).cast (by simp[Finset.insert_erase h])

def orRight' {p q : SyntacticFormula L} (h : p ⋎ q ∈ Δ) (d : ⊩ insert q (Δ.erase (p ⋎ q))) : ⊩ Δ :=
  (orRight _ p q d).cast (by simp[Finset.insert_erase h])

def or {p q : SyntacticFormula L} (d : ⊩ insert p (insert q Δ)) : ⊩ insert (p ⋎ q) Δ :=
  have : ⊩ insert (p ⋎ q) (insert q Δ) := orLeft _ p q d
  (orRight (insert (p ⋎ q) Δ) p q (this.cast (by ext; simp; tauto))).cast (by simp)

def and' {p q : SyntacticFormula L} (h : p ⋏ q ∈ Δ) (dp : ⊩ insert p (Δ.erase (p ⋏ q))) (dq : ⊩ insert q (Δ.erase (p ⋏ q))) : ⊩ Δ :=
  (and _ p q dp dq).cast (by simp[Finset.insert_erase h])

def all' {p : SyntacticSubFormula L 1} (h : ∀' p ∈ Δ) (d : ⊩ insert (free p) (shifts $ Δ.erase (∀' p))) : ⊩ Δ :=
  (all _ p d).cast (by simp[Finset.insert_erase h])

def ex' {p : SyntacticSubFormula L 1} (t : SyntacticTerm L) (h : ∃' p ∈ Δ)
  (d : ⊩ insert (subst t p) (Δ.erase (∃' p))) : ⊩ Δ :=
  (ex _ t p d).cast (by simp[Finset.insert_erase h])

@[simp] lemma ne_step_max (n m : ℕ) : n ≠ max n m + 1 :=
  ne_of_lt $ Nat.lt_succ_of_le $ by simp

@[simp] lemma ne_step_max' (n m : ℕ) : n ≠ max m n + 1 :=
  ne_of_lt $ Nat.lt_succ_of_le $ by simp

def em {p : SyntacticFormula L} {Δ : Finset (SyntacticFormula L)} (hpos : p ∈ Δ) (hneg : ~p ∈ Δ) : ⊩ Δ := by
  induction p using SubFormula.formulaRec generalizing Δ
  case hverum    => exact verum Δ hpos
  case hfalsum   => exact verum Δ hneg
  case hrel r v  => exact axL Δ r v hpos hneg
  case hnrel r v => exact axL Δ r v hneg hpos
  case hall p ih =>
    exact all' hpos $ ex' (p := ~ shift p) &0
      (by simp; exact Or.inr (by simp[shifts, shiftEmb_eq_shift]; exact ⟨_, hneg, by simp⟩))
      (ih (by simp; exact Or.inr $ ne_of_ne_complexity $ by simp[shift]) (by simp))
  case hex p ih =>
    simp at hneg
    exact all' hneg $ ex' (p := shift p) &0
      (by simp; exact Or.inr (by simp[shifts, shiftEmb_eq_shift]; exact ⟨_, hpos, by simp⟩))
      (ih (by simp) (by simp; exact Or.inr $ ne_of_ne_complexity $ by simp[shift]))
  case hand p q ihp ihq =>
    simp at hneg
    exact and' hpos
      (orLeft' (p := ~p) (q := ~q) (by simp[hneg]) $ ihp (by simp; exact Or.inr $ ne_of_ne_complexity (by simp)) (by simp))
      (orRight' (p := ~p) (q := ~q) (by simp[hneg]) $ ihq (by simp; exact Or.inr $ ne_of_ne_complexity (by simp)) (by simp))
  case hor p q ihp ihq =>
    simp at hneg
    exact and' hneg
      (orLeft' (p := p) (q := q) (by simp[hpos]) $ ihp (by simp) (by simp; exact Or.inr $ ne_of_ne_complexity (by simp)))
      (orRight' (p := p) (q := q) (by simp[hpos]) $ ihq (by simp) (by simp; exact Or.inr $ ne_of_ne_complexity (by simp)))

section Hom
variable
  {L₁ : Language} [∀ k, DecidableEq (L₁.func k)] [∀ k, DecidableEq (L₁.rel k)]
  {L₂ : Language} [∀ k, DecidableEq (L₂.func k)] [∀ k, DecidableEq (L₂.rel k)]
  {Δ₁ Γ₁ : Finset (SyntacticFormula L₁)}

lemma shifts_image (Φ : L₁ →ᵥ L₂) {Δ : Finset (SyntacticFormula L₁)} :
     shifts (Finset.image Φ.onSubFormula₁ Δ) = (Finset.image Φ.onSubFormula₁ (shifts Δ)) :=
  by simp[shifts, shiftEmb, Finset.map_eq_image, Finset.image_image, Function.comp, SubFormula.onSubFormula₁_shift]

def onDerivation (Φ : L₁ →ᵥ L₂) : ∀ {Δ : Finset (SyntacticFormula L₁)}, ⊩ Δ → ⊩ Finset.image Φ.onSubFormula₁ Δ
  | _, axL Δ r v hrel hnrel =>
      axL _ (Φ.onRel r) (fun i => Φ.onSubTerm (v i))
        (Finset.mem_image_of_mem _ hrel) (Finset.mem_image_of_mem _ hnrel)
  | _, verum Δ h            => verum _ (by simpa using Finset.mem_image_of_mem Φ.onSubFormula₁ h)
  | _, orLeft Δ p q d       =>
      have : ⊩ insert (Φ.onSubFormula₁ p ⋎ Φ.onSubFormula₁ q) (Δ.image Φ.onSubFormula₁) :=
        orLeft _ _ _ ((onDerivation Φ d).cast (by simp))
      this.cast (by simp)
  | _, orRight Δ p q d       =>
      have : ⊩ insert (Φ.onSubFormula₁ p ⋎ Φ.onSubFormula₁ q) (Δ.image Φ.onSubFormula₁) :=
        orRight _ _ _ ((onDerivation Φ d).cast (by simp))
      this.cast (by simp)
  | _, and Δ p q dp dq      =>
      have : ⊩ insert (Φ.onSubFormula₁ p ⋏ Φ.onSubFormula₁ q) (Finset.image Φ.onSubFormula₁ Δ) :=
        and _ _ _ ((onDerivation Φ dp).cast (by simp)) ((onDerivation Φ dq).cast (by simp))
      this.cast (by simp)
  | _, all Δ p d            =>
      have : ⊩ insert (∀' Φ.onSubFormula₁ p) (Finset.image Φ.onSubFormula₁ Δ) :=
        all _ _ (by simpa[←SubFormula.onSubFormula₁_free, shifts_image] using onDerivation Φ d)
      this.cast (by simp)
  | _, ex Δ t p d           =>
      have : ⊩ insert (∃' Φ.onSubFormula₁ p) (Finset.image Φ.onSubFormula₁ Δ) :=
        ex _ (Φ.onSubTerm t) _ (by simpa[←SubFormula.onSubFormula₁_subst] using onDerivation Φ d)
      this.cast (by simp)

end Hom

private lemma free_bind₀_eq (f : ℕ → SyntacticTerm L) (p : SyntacticSubFormula L 1) :
    free (bind₀ (fun x => SubTerm.bShift (f x)) p) = bind₀ (&0 :>ₙ fun x => SubTerm.shift (f x)) (free p) := by
  simp[free, bind_bind, Matrix.vecConsLast_vecEmpty]; congr; funext x
  simp[SubTerm.free, SubTerm.bShift, SubTerm.shift, SubTerm.map, SubTerm.bind_bind, eq_finZeroElim]

private lemma shift_bind₀_eq (f : ℕ → SyntacticTerm L) (p : SyntacticFormula L) :
    shift (bind₀ f p) = bind₀ (&0 :>ₙ fun x => SubTerm.shift (f x)) (shift p) := by
  simp[shift, map, bind₀, bind_bind]; congr

private lemma bind₀_subst_eq (f : ℕ → SyntacticTerm L) (t) (p : SyntacticSubFormula L 1) :
    bind₀ f (subst t p) = subst (t.bind SubTerm.bvar f) (bind₀ (SubTerm.bShift ∘ f) p) := by
  simp[subst, bind_bind, Fin.eq_zero, SubTerm.bShift, SubTerm.map, SubTerm.bind_bind, eq_finZeroElim]; congr

def onBind : ∀ {Δ : Finset (SyntacticFormula L)}, ⊩ Δ → ∀ (f : ℕ → SyntacticTerm L), ⊩ Δ.image (bind₀ f)
  | _, axL Δ r v hrel hnrel, f => axL _ r (fun i => (v i).bind SubTerm.bvar f) (Finset.mem_image_of_mem _ hrel) (Finset.mem_image_of_mem _ hnrel)
  | _, verum Δ h,            _ => verum _ (Finset.mem_image_of_mem _ h)
  | _, orLeft Δ p q d,       f =>
    have : ⊩ insert (bind₀ f p ⋎ bind₀ f q) (Δ.image (bind₀ f)) := orLeft _ _ _ ((onBind d f).cast (by simp))
    this.cast (by simp)
  | _, orRight Δ p q d,      f =>
    have : ⊩ insert (bind₀ f p ⋎ bind₀ f q) (Δ.image (bind₀ f)) := orRight _ _ _ ((onBind d f).cast (by simp))
    this.cast (by simp)
  | _, and Δ p q dp dq,      f =>
    have : ⊩ insert (bind₀ f p ⋏ bind₀ f q) (Δ.image (bind₀ f)) := and _ _ _ ((onBind dp f).cast (by simp)) ((onBind dq f).cast (by simp))
    this.cast (by simp)
  | _, all Δ p d,            f =>
    have : ⊩ (insert (free p) (shifts Δ)).image (bind₀ (&0 :>ₙ fun x => SubTerm.shift (f x))).toFun := onBind d (&0 :>ₙ fun x => (f x).shift)
    have : ⊩ insert (∀' (bind₀ (SubTerm.bShift ∘ f)) p) (Δ.image (bind₀ f).toFun) :=
      all _ _ (by simpa[free_bind₀_eq, shift_bind₀_eq, shifts_eq_image, Finset.image_image, Function.comp] using this)
    this.cast (by simp)
  | _, ex Δ t p d,           f =>
    have : ⊩ (insert (subst t p) Δ).image (bind₀ f) := onBind d f
    have : ⊩ insert (∃' bind₀ (SubTerm.bShift ∘ f) p) (Δ.image (bind₀ f)) :=
      ex _ (SubTerm.bind SubTerm.bvar f t) _ (by simpa[bind₀_subst_eq] using this)
    this.cast (by simp)

def onMap {Δ : Finset (SyntacticFormula L)} (d : ⊩ Δ) (f : ℕ → ℕ) : ⊩ Δ.image (map₀ f) := onBind d _

private lemma map_subst_eq_free (p : SyntacticSubFormula L 1) (h : ¬p.fvar? m) :
    map₀ (fun x => if x = m then 0 else x + 1) (subst &m p) = free p := by
  simp[free, subst, map₀, map, bind_bind, Fin.eq_zero, Matrix.vecConsLast_vecEmpty, Matrix.constant_eq_singleton]
  exact bind_eq_of_funEqOn _ _ _ _ (by intro x hx; simp; rintro rfl; contradiction)

private lemma image_map₀_eq_shifts (Δ : Finset $ SyntacticFormula L) (h : ∀ p ∈ Δ, ¬p.fvar? m) :
    Δ.image (map₀ (fun x => if x = m then 0 else x + 1)) = shifts Δ := by
  simp[shifts_eq_image]; apply Finset.image_congr
  simp[Set.EqOn]; intro p hp;
  simp[shift, map₀, map]
  exact bind_eq_of_funEqOn _ _ _ _ (by intro x hx; simp; rintro rfl; have := h p hp; contradiction)

def genelalizeByNewver {p : SyntacticSubFormula L 1} (hp : ¬p.fvar? m) (hΔ : ∀ q ∈ Δ, ¬q.fvar? m)
  (d : ⊩ insert (subst &m p) Δ) : ⊩ insert (∀' p) Δ := by
  have : ⊩ insert (free p) (shifts Δ) := by
    simpa[map_subst_eq_free p hp, image_map₀_eq_shifts Δ hΔ] using onMap d (fun x => if x = m then 0 else x + 1)
  exact all Δ p this

variable [∀ k, Encodable (L.func k)] {μ : Type _} [Encodable μ]

def exOfInstances (v : List (SyntacticTerm L)) (p : SyntacticSubFormula L 1)
  (h : ⊩ (v.map (subst · p)).toFinset ∪ Γ) : ⊩ insert (∃' p) Γ := by
  induction' v with t v ih generalizing Γ <;> simp at h
  · exact weakening h (Finset.subset_insert _ Γ)
  · exact Derivation.cast (ih (Γ := insert (∃' p) Γ)
      (Derivation.cast (ex _ t p h) (by ext r; simp))) (by simp)

end Derivation

namespace Proof

end Proof

end FirstOrder


/-
Copyright (c) 2020 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen
-/
import field_theory.minpoly
import linear_algebra.free_module
import ring_theory.adjoin
import ring_theory.adjoin_root
import ring_theory.algebraic

/-!
# Power basis

This file defines a structure `power_basis R S`, giving a basis of the
`R`-algebra `S` as a finite list of powers `1, x, ..., x^n`.
There are also constructors for `power_basis` when adjoining an algebraic
element to a ring/field.

## Definitions

* `power_basis R A`: a structure containing an `x` and an `n` such that
`1, x, ..., x^n` is a basis for the `R`-algebra `A` (viewed as an `R`-module).

* `findim (hf : f ≠ 0) : finite_dimensional.findim K (adjoin_root f) = f.nat_degree`,
  the dimension of `adjoin_root f` equals the degree of `f`

* `power_basis.lift (pb : power_basis R S)`: if `y : S'` satisfies the same
  equations as `pb.gen`, this is the map `S →ₐ[R] S'` sending `pb.gen` to `y`

* `power_basis.equiv`: if two power bases satisfy the same equations, they are
  equivalent as algebras

## Implementation notes

Throughout this file, `R`, `S`, ... are `comm_ring`s, `A`, `B`, ... are
`integral_domain`s and `K`, `L`, ... are `field`s.
`S` is an `R`-algebra, `B` is an `A`-algebra, `L` is a `K`-algebra.

## Tags

power basis, powerbasis

-/

open polynomial

variables {R S T : Type*} [comm_ring R] [comm_ring S] [comm_ring T]
variables [algebra R S] [algebra S T] [algebra R T] [is_scalar_tower R S T]
variables {A B : Type*} [integral_domain A] [integral_domain B] [algebra A B]
variables {K L : Type*} [field K] [field L] [algebra K L]

/-- `pb : power_basis R S` states that `1, pb.gen, ..., pb.gen ^ (pb.dim - 1)`
is a basis for the `R`-algebra `S` (viewed as `R`-module).

This is a structure, not a class, since the same algebra can have many power bases.
For the common case where `S` is defined by adjoining an integral element to `R`,
the canonical power basis is given by `{algebra,intermediate_field}.adjoin.power_basis`.
-/
@[nolint has_inhabited_instance]
structure power_basis (R S : Type*) [comm_ring R] [ring S] [algebra R S] :=
(gen : S)
(dim : ℕ)
(is_basis : is_basis R (λ (i : fin dim), gen ^ (i : ℕ)))

namespace power_basis

/-- Cannot be an instance because `power_basis` cannot be a class. -/
lemma finite_dimensional [algebra K S] (pb : power_basis K S) : finite_dimensional K S :=
finite_dimensional.of_fintype_basis pb.is_basis

lemma findim [algebra K S] (pb : power_basis K S) : finite_dimensional.findim K S = pb.dim :=
by rw [finite_dimensional.findim_eq_card_basis pb.is_basis, fintype.card_fin]

/-- TODO: this mixes `polynomial` and `finsupp`, we should hide this behind a
new function `polynomial.of_finsupp`. -/
lemma polynomial.mem_supported_range {f : polynomial R} {d : ℕ} :
  (f : finsupp ℕ R) ∈ finsupp.supported R R (↑(finset.range d) : set ℕ) ↔ f.degree < d :=
by { simp_rw [finsupp.mem_supported', finset.mem_coe, finset.mem_range, not_lt,
              degree_lt_iff_coeff_zero],
     refl }

lemma mem_span_pow' {x y : S} {d : ℕ} :
  y ∈ submodule.span R (set.range (λ (i : fin d), x ^ (i : ℕ))) ↔
    ∃ f : polynomial R, f.degree < d ∧ y = aeval x f :=
begin
  have : set.range (λ (i : fin d), x ^ (i : ℕ)) = (λ (i : ℕ), x ^ i) '' ↑(finset.range d),
  { ext n,
    simp_rw [set.mem_range, set.mem_image, finset.mem_coe, finset.mem_range],
    exact ⟨λ ⟨⟨i, hi⟩, hy⟩, ⟨i, hi, hy⟩, λ ⟨i, hi, hy⟩, ⟨⟨i, hi⟩, hy⟩⟩ },
  rw [this, finsupp.mem_span_iff_total],
  -- In the next line we use that `polynomial R := finsupp ℕ R`.
  -- It would be nice to have a function `polynomial.of_finsupp`.
  apply exists_congr,
  rintro (f : polynomial R),
  simp only [exists_prop, polynomial.mem_supported_range, eq_comm],
  apply and_congr iff.rfl,
  split;
  { rintro rfl;
    rw [finsupp.total_apply, aeval_def, eval₂_eq_sum, eq_comm],
    apply finset.sum_congr rfl,
    rintro i -,
    simp only [algebra.smul_def] }
end

lemma mem_span_pow {x y : S} {d : ℕ} (hd : d ≠ 0) :
  y ∈ submodule.span R (set.range (λ (i : fin d), x ^ (i : ℕ))) ↔
    ∃ f : polynomial R, f.nat_degree < d ∧ y = aeval x f :=
begin
  rw mem_span_pow',
  split;
  { rintros ⟨f, h, hy⟩,
    refine ⟨f, _, hy⟩,
    by_cases hf : f = 0,
    { simp only [hf, nat_degree_zero, degree_zero] at h ⊢,
      exact lt_of_le_of_ne (nat.zero_le d) hd.symm <|> exact with_bot.bot_lt_some d },
    simpa only [degree_eq_nat_degree hf, with_bot.coe_lt_coe] using h },
end

lemma dim_ne_zero [nontrivial S] (pb : power_basis R S) : pb.dim ≠ 0 :=
λ h, one_ne_zero $
show (1 : S) = 0,
by { rw [← pb.is_basis.total_repr 1, finsupp.total_apply, finsupp.sum_fintype],
     { refine finset.sum_eq_zero (λ x hx, _),
       cases x with x x_lt,
       rw h at x_lt,
       cases x_lt },
     { simp } }

lemma dim_pos [nontrivial S] (pb : power_basis R S) : 0 < pb.dim :=
nat.pos_of_ne_zero pb.dim_ne_zero

lemma exists_eq_aeval [nontrivial S] (pb : power_basis R S) (y : S) :
  ∃ f : polynomial R, f.nat_degree < pb.dim ∧ y = aeval pb.gen f :=
(mem_span_pow pb.dim_ne_zero).mp (pb.is_basis.mem_span y)

section minpoly

open_locale big_operators

variable [algebra A S]

/-- `pb.minpoly_gen` is a minimal polynomial for `pb.gen`.

If `A` is not a field, it might not necessarily be *the* minimal polynomial,
however `nat_degree_minpoly` shows its degree is indeed minimal.
-/
noncomputable def minpoly_gen (pb : power_basis A S) : polynomial A :=
X ^ pb.dim -
  ∑ (i : fin pb.dim), C (pb.is_basis.repr (pb.gen ^ pb.dim) i) * X ^ (i : ℕ)

@[simp]
lemma nat_degree_minpoly_gen (pb : power_basis A S) :
  nat_degree (minpoly_gen pb) = pb.dim :=
begin
  unfold minpoly_gen,
  apply nat_degree_eq_of_degree_eq_some,
  rw degree_sub_eq_left_of_degree_lt; rw degree_X_pow,
  apply degree_sum_fin_lt
end

lemma minpoly_gen_monic (pb : power_basis A S) : monic (minpoly_gen pb) :=
begin
  apply monic_sub_of_left (monic_pow (monic_X) _),
  rw degree_X_pow,
  exact degree_sum_fin_lt _
end

lemma minpoly_gen_ne_zero (pb : power_basis A S) : minpoly_gen pb ≠ 0 :=
pb.minpoly_gen_monic.ne_zero

@[simp]
lemma degree_minpoly_gen (pb : power_basis A S) : degree (minpoly_gen pb) = pb.dim :=
by rw [degree_eq_nat_degree pb.minpoly_gen_ne_zero, nat_degree_minpoly_gen, with_bot.coe_eq_coe]

lemma degree_minpoly_gen_pos [nontrivial S] (pb : power_basis A S) :
  0 < degree (minpoly_gen pb) :=
by { rw [degree_minpoly_gen, ← with_bot.coe_zero, with_bot.coe_lt_coe], exact pb.dim_pos }

lemma nat_degree_minpoly_gen_pos [nontrivial S] (pb : power_basis A S) :
  0 < nat_degree (minpoly_gen pb) :=
by { rw nat_degree_minpoly_gen, exact pb.dim_pos }

@[simp]
lemma aeval_minpoly_gen (pb : power_basis A S) : aeval pb.gen (minpoly_gen pb) = 0 :=
begin
  simp_rw [minpoly_gen, alg_hom.map_sub, alg_hom.map_sum, alg_hom.map_mul, alg_hom.map_pow,
           aeval_C, ← algebra.smul_def, aeval_X],
  refine sub_eq_zero.mpr ((pb.is_basis.total_repr (pb.gen ^ pb.dim)).symm.trans _),
  rw [finsupp.total_apply, finsupp.sum_fintype],
  intro i, rw zero_smul
end

lemma is_integral_gen (pb : power_basis A S) : is_integral A pb.gen :=
⟨minpoly_gen pb, minpoly_gen_monic pb, aeval_minpoly_gen pb⟩

lemma dim_le_nat_degree_of_root (h : power_basis A S) {p : polynomial A}
  (ne_zero : p ≠ 0) (root : aeval h.gen p = 0) :
  h.dim ≤ p.nat_degree :=
begin
  refine le_of_not_lt (λ hlt, ne_zero _),
  let p_coeff : fin (h.dim) → A := λ i, p.coeff i,
  suffices : ∀ i, p_coeff i = 0,
  { ext i,
    by_cases hi : i < h.dim,
    { exact this ⟨i, hi⟩ },
    exact coeff_eq_zero_of_nat_degree_lt (lt_of_lt_of_le hlt (le_of_not_gt hi)) },
  intro i,
  refine linear_independent_iff'.mp h.is_basis.1 finset.univ _ _ i (finset.mem_univ _),
  rw aeval_eq_sum_range' hlt at root,
  rw finset.sum_fin_eq_sum_range,
  convert root,
  ext i,
  split_ifs with hi,
  { refl },
  { rw [coeff_eq_zero_of_nat_degree_lt (lt_of_lt_of_le hlt (le_of_not_gt hi)),
        zero_smul] }
end

lemma dim_le_degree_of_root (h : power_basis A S) {p : polynomial A}
  (ne_zero : p ≠ 0) (root : aeval h.gen p = 0) :
  ↑h.dim ≤ p.degree :=
begin
  have := dim_le_nat_degree_of_root h ne_zero root,
  rwa [← with_bot.coe_le_coe, ← degree_eq_nat_degree ne_zero] at this,
end

@[simp]
lemma degree_minpoly (pb : power_basis A S) :
  (minpoly A pb.gen).degree = pb.dim :=
begin
  refine le_antisymm _
    (dim_le_degree_of_root pb (minpoly.ne_zero pb.is_integral_gen) (minpoly.aeval _ _)),
  rw [← nat_degree_minpoly_gen, ← degree_eq_nat_degree (minpoly_gen_monic pb).ne_zero],
  exact minpoly.min _ _ (minpoly_gen_monic pb) (aeval_minpoly_gen pb)
end

@[simp]
lemma nat_degree_minpoly (pb : power_basis A S) :
  (minpoly A pb.gen).nat_degree = pb.dim :=
by rw [← with_bot.coe_eq_coe, ← degree_minpoly pb,
       degree_eq_nat_degree (minpoly.ne_zero pb.is_integral_gen)]

lemma minpoly_gen_eq [algebra K S] (pb : power_basis K S) :
  pb.minpoly_gen = minpoly K pb.gen :=
begin
  apply minpoly.unique _ _ pb.minpoly_gen_monic pb.aeval_minpoly_gen,
  intros q q_monic aeval_q,
  rw [degree_minpoly_gen pb, ← degree_minpoly pb],
  exact minpoly.min _ _ q_monic aeval_q
end

end minpoly

section equiv

variables [algebra A S] {S' : Type*} [comm_ring S'] [algebra A S']

lemma nat_degree_lt_nat_degree {p q : polynomial R} (hp : p ≠ 0) (hpq : p.degree < q.degree) :
  p.nat_degree < q.nat_degree :=
begin
  by_cases hq : q = 0, { rw [hq, degree_zero] at hpq, have := not_lt_bot hpq, contradiction },
  rwa [degree_eq_nat_degree hp, degree_eq_nat_degree hq, with_bot.coe_lt_coe] at hpq
end

lemma constr_pow_aeval (pb : power_basis A S) {y : S'}
  (hy : aeval y pb.minpoly_gen = 0) (f : polynomial A) :
  pb.is_basis.constr (λ i, y ^ (i : ℕ)) (aeval pb.gen f) = aeval y f :=
begin
  rw [← aeval_mod_by_monic_eq_self_of_root
          pb.minpoly_gen_monic
          pb.aeval_minpoly_gen,
      ← @aeval_mod_by_monic_eq_self_of_root _ _ _ _ _ f _
          pb.minpoly_gen_monic y hy],
  by_cases hf : f %ₘ pb.minpoly_gen = 0,
  { simp only [hf, alg_hom.map_zero, linear_map.map_zero] },
  have : (f %ₘ pb.minpoly_gen).nat_degree < pb.dim,
  { rw ← pb.nat_degree_minpoly_gen,
    apply nat_degree_lt_nat_degree hf,
    exact degree_mod_by_monic_lt _ pb.minpoly_gen_monic pb.minpoly_gen_ne_zero },
  rw [aeval_eq_sum_range' this, aeval_eq_sum_range' this, linear_map.map_sum],
  refine finset.sum_congr rfl (λ i (hi : i ∈ finset.range pb.dim), _),
  rw finset.mem_range at hi,
  rw linear_map.map_smul,
  congr,
  exact @constr_basis _ _ _ _ _ _ _ _ _ _ _ (⟨i, hi⟩ : fin pb.dim) pb.is_basis,
end

lemma constr_pow_gen (pb : power_basis A S) {y : S'}
  (hy : aeval y pb.minpoly_gen = 0) :
  pb.is_basis.constr (λ i, y ^ (i : ℕ)) pb.gen = y :=
by { convert pb.constr_pow_aeval hy X; rw aeval_X }

lemma constr_pow_algebra_map (pb : power_basis A S) {y : S'}
  (hy : aeval y pb.minpoly_gen = 0) (x : A) :
  pb.is_basis.constr (λ i, y ^ (i : ℕ)) (algebra_map A S x) = algebra_map A S' x :=
by { convert pb.constr_pow_aeval hy (C x); rw aeval_C }

lemma constr_pow_mul [nontrivial S] (pb : power_basis A S) {y : S'}
  (hy : aeval y pb.minpoly_gen = 0) (x x' : S) :
  pb.is_basis.constr (λ i, y ^ (i : ℕ)) (x * x') =
    pb.is_basis.constr (λ i, y ^ (i : ℕ)) x * pb.is_basis.constr (λ i, y ^ (i : ℕ)) x' :=
begin
  obtain ⟨f, hf, rfl⟩ := pb.exists_eq_aeval x,
  obtain ⟨g, hg, rfl⟩ := pb.exists_eq_aeval x',
  simp only [← aeval_mul, pb.constr_pow_aeval hy]
end

/-- `pb.lift y hy` is the algebra map sending `pb.gen` to `y`,
where `hy` states the higher powers of `y` are the same as the higher powers of `pb.gen`. -/
noncomputable def lift [nontrivial S] (pb : power_basis A S) (y : S')
  (hy : aeval y pb.minpoly_gen = 0) :
  S →ₐ[A] S' :=
{ map_one' := by { convert pb.constr_pow_algebra_map hy 1 using 2; rw ring_hom.map_one },
  map_zero' := by { convert pb.constr_pow_algebra_map hy 0 using 2; rw ring_hom.map_zero },
  map_mul' := pb.constr_pow_mul hy,
  commutes' := pb.constr_pow_algebra_map hy,
  .. pb.is_basis.constr (λ i, y ^ (i : ℕ)) }

@[simp] lemma lift_gen [nontrivial S] (pb : power_basis A S) (y : S')
  (hy : aeval y pb.minpoly_gen = 0) :
  pb.lift y hy pb.gen = y :=
pb.constr_pow_gen hy

@[simp] lemma lift_aeval [nontrivial S] (pb : power_basis A S) (y : S')
  (hy : aeval y pb.minpoly_gen = 0) (f : polynomial A) :
  pb.lift y hy (aeval pb.gen f) = aeval y f :=
pb.constr_pow_aeval hy f

/-- `pb.equiv pb' h` is an equivalence of algebras with the same power basis. -/
noncomputable def equiv [nontrivial S] [nontrivial S']
  (pb : power_basis A S) (pb' : power_basis A S')
  (h : pb.minpoly_gen = pb'.minpoly_gen) :
  S ≃ₐ[A] S' :=
alg_equiv.of_alg_hom
  (pb.lift pb'.gen (h.symm ▸ pb'.aeval_minpoly_gen))
  (pb'.lift pb.gen (h ▸ pb.aeval_minpoly_gen))
  (by { ext x, obtain ⟨f, hf, rfl⟩ := pb'.exists_eq_aeval x, simp })
  (by { ext x, obtain ⟨f, hf, rfl⟩ := pb.exists_eq_aeval x, simp })

@[simp]
lemma equiv_aeval [nontrivial S] [nontrivial S']
  (pb : power_basis A S) (pb' : power_basis A S')
  (h : pb.minpoly_gen = pb'.minpoly_gen)
  (f : polynomial A) :
  pb.equiv pb' h (aeval pb.gen f) = aeval pb'.gen f :=
pb.lift_aeval _ (h.symm ▸ pb'.aeval_minpoly_gen) _

@[simp]
lemma equiv_gen [nontrivial S] [nontrivial S']
  (pb : power_basis A S) (pb' : power_basis A S')
  (h : pb.minpoly_gen = pb'.minpoly_gen) :
  pb.equiv pb' h pb.gen = pb'.gen :=
pb.lift_gen _ (h.symm ▸ pb'.aeval_minpoly_gen)

local attribute [irreducible] power_basis.lift

@[simp]
lemma equiv_symm [nontrivial S] [nontrivial S']
  (pb : power_basis A S) (pb' : power_basis A S')
  (h : pb.minpoly_gen = pb'.minpoly_gen) :
  (pb.equiv pb' h).symm = pb'.equiv pb h.symm :=
rfl

/-- An algebra equivalence induces an equivalence of power bases.

This definition is used for either direction of `power_basis.congr`.
-/
def congr_aux {R A A' : Type*} [comm_ring R] [ring A] [ring A']
  [algebra R A] [algebra R A'] (e : A ≃ₐ[R] A')
  (pb : power_basis R A) : power_basis R A' :=
{ gen := e pb.gen,
  dim := pb.dim,
  is_basis := begin
      simp only [← e.map_pow],
      convert linear_equiv.is_basis pb.is_basis e.to_linear_equiv
    end }

@[ext]
lemma ext {R A : Type*} [integral_domain R] [ring A] [algebra R A]
  {pb pb' : power_basis R A} (h : pb.gen = pb'.gen) : pb = pb' :=
begin
  cases pb, cases pb', congr,
  { exact h },
  convert le_antisymm
      (pb'_is_basis.card_le_card_of_linear_independent pb_is_basis.1)
      (pb_is_basis.card_le_card_of_linear_independent pb'_is_basis.1);
    rw fintype.card_fin
end

lemma ext_iff {R A : Type*} [integral_domain R] [ring A] [algebra R A]
  {pb pb' : power_basis R A} : pb = pb' ↔ pb.gen = pb'.gen :=
⟨λ h, by rw h, power_basis.ext⟩

/-- An algebra equivalence induces an equivalence of power bases. -/
def congr {R A A' : Type*} [integral_domain R] [ring A] [ring A']
  [algebra R A] [algebra R A'] (e : A ≃ₐ[R] A') :
  power_basis R A ≃ power_basis R A' :=
{ to_fun := power_basis.congr_aux e,
  inv_fun := power_basis.congr_aux e.symm,
  left_inv := λ pb, power_basis.ext (e.symm_apply_apply pb.gen),
  right_inv := λ pb, power_basis.ext (e.apply_symm_apply pb.gen) }

end equiv

end power_basis

namespace algebra

open power_basis

lemma mem_span_power_basis [nontrivial R] {x y : S} (hx : _root_.is_integral R x)
  (hy : ∃ f : polynomial R, y = aeval x f) :
  y ∈ submodule.span R (set.range (λ (i : fin (minpoly R x).nat_degree),
    x ^ (i : ℕ))) :=
begin
  obtain ⟨f, rfl⟩ := hy,
  rw mem_span_pow',
  have := minpoly.monic hx,
  refine ⟨f.mod_by_monic (minpoly R x),
    lt_of_lt_of_le (degree_mod_by_monic_lt _ this (ne_zero_of_monic this)) degree_le_nat_degree,
    _⟩,
  conv_lhs { rw ← mod_by_monic_add_div f this },
  simp only [add_zero, zero_mul, minpoly.aeval, aeval_add, alg_hom.map_mul]
end

lemma linear_independent_power_basis [algebra K S] {x : S} (hx : _root_.is_integral K x) :
  linear_independent K (λ (i : fin (minpoly K x).nat_degree), x ^ (i : ℕ)) :=
begin
  rw linear_independent_iff,
  intros p hp,
  let f : polynomial K := p.sum (λ i, monomial i),
  have f_def : ∀ (i : fin _), f.coeff i = p i,
  { intro i,
    -- TODO: how can we avoid unfolding here?
    change (p.sum (λ i pi, finsupp.single i pi) : ℕ →₀ K) i = p i,
    simp_rw [finsupp.sum_apply, finsupp.single_apply, finsupp.sum],
    rw [finset.sum_eq_single, if_pos rfl],
    { intros b _ hb,
      rw if_neg (mt (λ h, _) hb),
      exact fin.coe_injective h },
    { intro hi,
      split_ifs; { exact finsupp.not_mem_support_iff.mp hi } } },
  have f_def' : ∀ i, f.coeff i = if hi : i < _ then p ⟨i, hi⟩ else 0,
  { intro i,
    split_ifs with hi,
    { exact f_def ⟨i, hi⟩ },
    -- TODO: how can we avoid unfolding here?
    change (p.sum (λ i pi, finsupp.single i pi) : ℕ →₀ K) i = 0,
    simp_rw [finsupp.sum_apply, finsupp.single_apply, finsupp.sum],
    apply finset.sum_eq_zero,
    rintro ⟨j, hj⟩ -,
    apply if_neg (mt _ hi),
    rintro rfl,
    exact hj },
  suffices : f = 0,
  { ext i, rw [← f_def, this, coeff_zero, finsupp.zero_apply] },
  contrapose hp with hf,
  intro h,
  have : (minpoly K x).degree ≤ f.degree,
  { apply minpoly.degree_le_of_ne_zero K x hf,
    convert h,
    rw [finsupp.total_apply, aeval_def, eval₂_eq_sum, finsupp.sum_sum_index],
    { apply finset.sum_congr rfl,
      rintro i -,
      simp only [algebra.smul_def, monomial, finsupp.lsingle_apply, zero_mul, ring_hom.map_zero,
        finsupp.sum_single_index] },
    { intro, simp only [ring_hom.map_zero, zero_mul] },
    { intros, simp only [ring_hom.map_add, add_mul] } },
  have : ¬ (minpoly K x).degree ≤ f.degree,
  { apply not_le_of_lt,
    rw [degree_eq_nat_degree (minpoly.ne_zero hx), degree_lt_iff_coeff_zero],
    intros i hi,
    rw [f_def' i, dif_neg],
    exact not_lt_of_ge hi },
  contradiction
end

lemma power_basis_is_basis [algebra K S] {x : S} (hx : _root_.is_integral K x) :
  is_basis K (λ (i : fin (minpoly K x).nat_degree),
    (⟨x, subset_adjoin (set.mem_singleton x)⟩ ^ (i : ℕ) : adjoin K ({x} : set S))) :=
begin
  have hST : function.injective (algebra_map (adjoin K ({x} : set S)) S) := subtype.coe_injective,
  have hx' : _root_.is_integral K
    (show adjoin K ({x} : set S), from ⟨x, subset_adjoin (set.mem_singleton x)⟩),
  { apply (is_integral_algebra_map_iff hST).mp,
    convert hx,
    apply_instance },
  have minpoly_eq := minpoly.eq_of_algebra_map_eq hST hx' rfl,
  refine ⟨_, _root_.eq_top_iff.mpr _⟩,
  { have := linear_independent_power_basis hx',
    rwa minpoly_eq at this },
  { rintros ⟨y, hy⟩ _,
    have := mem_span_power_basis hx',
    rw minpoly_eq at this,
    apply this,
    { rw [adjoin_singleton_eq_range] at hy,
      obtain ⟨f, rfl⟩ := (aeval x).mem_range.mp hy,
      use f,
      ext,
      exact (is_scalar_tower.algebra_map_aeval K (adjoin K {x}) S ⟨x, _⟩ _).symm } }
end

/-- The power basis `1, x, ..., x ^ (d - 1)` for `K[x]`,
where `d` is the degree of the minimal polynomial of `x`. -/
noncomputable def adjoin.power_basis [algebra K S] {x : S} (hx : _root_.is_integral K x) :
  power_basis K (adjoin K ({x} : set S)) :=
{ gen := ⟨x, subset_adjoin (set.mem_singleton x)⟩,
  dim := (minpoly K x).nat_degree,
  is_basis := power_basis_is_basis hx }

end algebra

namespace adjoin_root

variables {f : polynomial K}

lemma power_basis_is_basis (hf : f ≠ 0) : is_basis K (λ (i : fin f.nat_degree), (root f ^ i.val)) :=
begin
  set f' := f * C (f.leading_coeff⁻¹) with f'_def,
  have deg_f' : f'.nat_degree = f.nat_degree,
  { rw [nat_degree_mul hf, nat_degree_C, add_zero],
    { rwa [ne.def, C_eq_zero, inv_eq_zero, leading_coeff_eq_zero] } },
  have f'_monic : monic f' := monic_mul_leading_coeff_inv hf,
  have aeval_f' : aeval (root f) f' = 0,
  { rw [f'_def, alg_hom.map_mul, aeval_eq, mk_self, zero_mul] },
  have hx : is_integral K (root f) := ⟨f', f'_monic, aeval_f'⟩,
  have minpoly_eq : f' = minpoly K (root f),
  { apply minpoly.unique K _ f'_monic aeval_f',
    intros q q_monic q_aeval,
    have commutes : (lift (algebra_map K (adjoin_root f)) (root f) q_aeval).comp (mk q) = mk f,
    { ext,
      { simp only [ring_hom.comp_apply, mk_C, lift_of], refl },
      { simp only [ring_hom.comp_apply, mk_X, lift_root] } },
    rw [degree_eq_nat_degree f'_monic.ne_zero, degree_eq_nat_degree q_monic.ne_zero,
        with_bot.coe_le_coe, deg_f'],
    apply nat_degree_le_of_dvd,
    { rw [←ideal.mem_span_singleton, ←ideal.quotient.eq_zero_iff_mem],
      change mk f q = 0,
      rw [←commutes, ring_hom.comp_apply, mk_self, ring_hom.map_zero] },
    { exact q_monic.ne_zero } },
  refine ⟨_, eq_top_iff.mpr _⟩,
  { rw [←deg_f', minpoly_eq],
    exact algebra.linear_independent_power_basis hx, },
  { rintros y -,
    rw [←deg_f', minpoly_eq],
    apply algebra.mem_span_power_basis hx,
    obtain ⟨g⟩ := y,
    use g,
    rw aeval_eq,
    refl }
end

/-- The power basis `1, root f, ..., root f ^ (d - 1)` for `adjoin_root f`,
where `f : polynomial K` of degree `d ≥ 0`. -/
noncomputable def power_basis (hf : f ≠ 0) :
  power_basis K (adjoin_root f) :=
{ gen := root f,
  dim := f.nat_degree,
  is_basis := power_basis_is_basis hf }

@[simp] lemma gen_eq (hf : f ≠ 0) : (adjoin_root.power_basis hf).gen = root f := rfl

lemma minpoly_gen_dvd (hf : f ≠ 0) :
  (adjoin_root.power_basis hf).minpoly_gen ∣ f :=
by { rw power_basis.minpoly_gen_eq, exact minpoly.dvd _ _ (adjoin_root.eval₂_root f) }

@[simp]
lemma minpoly_gen_eq (hf : irreducible f) (hfm : monic f) :
  (adjoin_root.power_basis hf.ne_zero).minpoly_gen = f :=
begin
  rw [(power_basis hf.ne_zero).minpoly_gen_eq, ← minpoly.unique' _ hf _ hfm],
  { exact field.to_nontrivial _ },
  { exact (power_basis hf.ne_zero).is_integral_gen },
  { exact adjoin_root.eval₂_root f }
end

end adjoin_root


import
  .lemmas.substitution
  .lemmas.big_step

open big_step

lemma big_subst_complete {E e S r} :
  (E, compile e, S) ⟹ₙᵥ (E, r :: S)
  → big_subst E e ⟹ r :=
begin
  assume h,
  induction' e,
  case EVal {
    rw compile at h,
    cases' h, cases' h,
    rw big_subst_val,
    apply RunVal
  },
  case EVar {
    rw compile at h,
    cases' h, cases' h,
    induction' _x,
    case bhead {
      rw [big_subst, subst, if_pos (eq.refl x), big_subst_val],
      apply RunVal
    },
    case btail {
      rw [big_subst, subst, if_neg h.symm],
      exact ih
    }
  },
  case EOp {
    rw compile at h, simp at h,
    rw big_subst_spread_op,
    cases' to_interm_results h with v h',
    cases' h' with he_1 h',
    cases' to_interm_results h' with u h'',
    cases' h'' with he h'',
    cases' h'', cases' h'',
    apply RunOp,
    exact ih_e he,
    exact ih_e_1 he_1
  },
  case EIf {
    rw compile at h, simp at h,
    rw big_subst_spread_if,
    cases' to_interm_results h with v h',
    cases' h' with he h',
    cases h',
    case ERunTBranch {
      cases' to_interm_results h'__x with u,
      cases' h_1 with he_1 h_1,
      cases' h_1,
      rw list.drop_length at h_1,
      cases' h_1,
      apply RunIfT,
      exact ih_e he,
      exact ih_e_1 he_1
    },
    case ERunFBranch {
      rename [h'__x hle, h'__x_1 he_2],
      simp at he_2,
      have H : ∀ xs, (compile e_1).append xs = compile e_1 ++ xs,
        assume xs, by refl,
      rw [nat.succ_eq_add_one,
          nat.add_comm,
          list.drop_add,
          list.drop_one, H,
          list.drop_append_of_le_length,
          list.drop_length,
          list.nil_append,
          list.tail] at he_2,
      apply RunIfF,
      exact ih_e he,
      exact ih_e_2 he_2,
      refl
    }
  },
  case ELet {
    rw compile at h, simp at h,
    cases' to_interm_results h with v h',
    cases' h' with he h',
    cases' h',
    cases' to_interm_results h' with u h'',
    cases' h'' with he_1 h'',
    cases' h'', cases' h'',
    rw big_subst_spread_let,
    apply RunLet,
    exact ih_e he,
    rw [subst_merge, big_subst_remove_append],
    exact ih_e_1 he_1
  }
end

theorem compile_complete_nv
  {e : exp} {r : val} :
    ([], compile e, []) ⟹ₙᵥ ([], [r])
  → e ⟹ r :=
assume h,
have H : big_subst [] e ⟹ r := big_subst_complete h,
by rw big_subst at H; exact H


import tactic.generalize_proofs

example (x : ℕ) (h : x < 2) : classical.some ⟨x, h⟩ < 2 :=
begin
  generalize_proofs a,
  guard_hyp a : ∃ x, x < 2,
  guard_target classical.some a < 2,
  exact classical.some_spec a,
end

example (a : ∃ x, x < 2) : classical.some a < 2 :=
begin
  generalize_proofs,
  guard_target classical.some a < 2,
  exact classical.some_spec a,
end

example (x : ℕ) (h : x < 2) (a : ∃ x, x < 2) : classical.some a < 2 :=
begin
  generalize_proofs,
  guard_target classical.some a < 2,
  exact classical.some_spec a,
end

example (x : ℕ) (h : x < 2) (H : classical.some ⟨x, h⟩ < 2) : classical.some ⟨x, h⟩ < 2 :=
begin
  generalize_proofs a at H ⊢,
  guard_hyp a : ∃ x, x < 2,
  guard_hyp H : classical.some a < 2,
  guard_target classical.some a < 2,
  exact H,
end


import ..lovelib

/-! # LoVe Demo 7: Metaprogramming

Users can extend Lean with custom tactics and tools. This kind of
programming—programming the prover—is called metaprogramming.

Lean's metaprogramming framework uses mostly the same notions and syntax as
Lean's input language itself. Abstract syntax trees __reflect__ internal data
structures, e.g., for expressions (terms). The prover's C++ internals are
exposed through Lean interfaces, which we can use for

* accessing the current context and goal;
* unifying expressions;
* querying and modifying the environment;
* setting attributes.

Most of Lean's predefined tactics are implemented in Lean (and not in C++).

Example applications:

* proof goal transformations;
* heuristic proof search;
* decision procedures;
* definition generators;
* advisor tools;
* exporters;
* ad hoc automation.

Advantages of Lean's metaprogramming framework:

* Users do not need to learn another programming language to write
  metaprograms; they can work with the same constructs and notation used to
  define ordinary objects in the prover's library.

* Everything in that library is available for metaprogramming purposes.

* Metaprograms can be written and debugged in the same interactive environment,
  encouraging a style where formal libraries and supporting automation are
  developed at the same time. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

open tactic

namespace LoVe

/-!

## Well-founded and non-well-founded recursion

The recursive functions we've written are structurally recursive.
But sometimes this feels like too strong of a restriction.
-/

def list.map {α β : Type} (f : α → β) : list α → list β
| [] := []
| (h::t) := f h :: list.map t

lemma list.map_length {α β : Type} (f : α → β): ∀ l :
  list α, list.length (list.map f l) = list.length l
| [] := rfl
| (h::t) := by simp [list.map, list.map_length]

def list.multimap₁ {α : Type} (f : α → α) : list α → list α
| [] := []
| (h::t) := f h :: list.multimap₁ (list.map f t)

def list.multimap₂ {α : Type} (f : α → α) : list α → list α
| [] := []
| (h::t) :=
  have hl : list.sizeof (list.map f t) < 1 + list.sizeof t := sorry,
  f h :: list.multimap₂ (list.map f t)

#eval list.multimap₂ (λ x, x + 1) [0, 0, 0, 0]

def list.multimap₃ {α : Type} (f : α → α) : list α → list α
| [] := []
| (h::t) :=
  have hl : list.length (list.map f t) < list.length t + 1 :=
    by simp [list.map_length, nat.lt_succ_self],
  f h :: list.multimap₃ (list.map f t)
using_well_founded {rel_tac := λ _ _, `[exact ⟨_, measure_wf list.length⟩]}

/-!
Proving well-foundedness can be arbitrarily hard.
-/

def f : ℕ → ℕ
| n := if n = 1 then 1
       else if n%2 = 0 then f (n/2)
       else f (3*n + 1)

/-!
All functions in "standard" Lean must terminate, otherwise we could prove false.

But maybe all we want to do is *compute* with the function, and not worry about
proving anything about it.

The keyword *meta* lets us do exactly this.
Like *noncomputable*, *meta* is sticky: anything that references a meta declaration
must be meta itself.
All it does is disable the well-foundedness checker.
-/

meta def g : ℕ → ℕ
| n := if n = 1 then 1
       else if n%2 = 0 then g (n/2)
       else g (3*n + 1)

#eval (list.iota 100).map g

meta def oops : false := oops

/-!

Note that this use of the word "meta" is somewhat misleading.
Nothing is "about Lean" yet, we've just defined a language extension.
Morally speaking, meta definitions are ones that we intend for "computation
purposes only."

## What are tactics, really?

Recall that when we write a tactic proof, it's generating a proof term under the hood.

Between each tactic we can inspect a *proof state*, which has a context and goal.

A tactic behaves like a function from proof state to proof state.
-/

lemma test_lemma : ∀ x, x = 3 → x + 10 = 13 :=
begin
  intros x hx,
  cases hx,
  refl
end

#print test_lemma

.

/-
But tactics can fail. So they're not total functions.
And tactics can also fail to terminate.
-/

-- example (x y z : ℕ) : x + y + z = z + y + x :=
-- by simp [add_comm x y, add_comm y x]

/-!

So it feels like we have something like

    meta def simp : simp_args → tactic_state → option tactic_state

Which is actually not so far from the truth!

We've mentioned the difference between `#reduce` and `#eval`.
`#eval` is for data only. It doesn't care about proof terms, instead interpreting
expressions in the Lean virtual machine.

It replaces certain data types and operations with more efficient implementations,
e.g. arithmetic on `nat`.

It also replaces certain *constants* with actual data.

-/

#print tactic_state
#print tactic_state.get_options

.

/-

So a tactic in Lean is like a function `tactic_state → tactic_state`.
It can use these uninterpreted constants like `get_options`.
In a `begin...end` block, Lean generates the initial tactic state.
Then it sequentially calls the tactics in the block, producing a new tactic state.
When a tactic leaves a state that has no goals, the proof is done.

There are some hiccups here.
* "State"? Sounds imperative!
* Stringing together `option`-valued functions sounds annoying.
* How do we write these? Can we read and write to the state at the same time?

These questions aren't unique to Lean -- these are common functional programming issues.
They have a solution: *monads*.

## Monads

Extra reference: https://leanprover.github.io/programming_in_lean/#07_Monads.html

Monads are an abstraction of "programming with side effects."
The side effects we'll be interested in are state and failure.

In general, a __monad__ is a type constructor `m` that depends on some type
parameter `α` (i.e., `m α`) equipped with two distinguished operations:

    `pure {α : Type} : α → m α`
    `bind {α β : Type} : m α → (α → m β) → m β`

Consider the following programming task:

    Implement a function `sum_2_5_7 ns` that sums up the second, fifth, and
    seventh items of a list `ns` of natural numbers. Use `option ℕ` for the
    result so that if the list has fewer than seven elements, you can return
    `option.none`.

A straightforward solution follows: -/

def sum_2_5_7 (ns : list ℕ) : option ℕ :=
match list.nth ns 1 with
| option.none    := option.none
| option.some n2 :=
  match list.nth ns 4 with
  | option.none    := option.none
  | option.some n5 :=
    match list.nth ns 6 with
    | option.none    := option.none
    | option.some n7 := option.some (n2 + n5 + n7)
    end
  end
end

/-!
`option` is a monad with failure. `some v` is the success case,
`none` is the failure case.

If `v : ℕ`, then `pure v = some v`. `bind` is `connect`:
-/

def connect {α : Type} {β : Type} :
  option α → (α → option β) → option β
| option.none     f := option.none
| (option.some a) f := f a

def sum_2_5_7₂ (ns : list ℕ) : option ℕ :=
connect (list.nth ns 1)
  (λn2, connect (list.nth ns 4)
     (λn5, connect (list.nth ns 6)
        (λn7, option.some (n2 + n5 + n7))))

def sum_2_5_7₆ (ns : list ℕ) : option ℕ :=
do
  n2 ← list.nth ns 1,
  n5 ← list.nth ns 4,
  n7 ← list.nth ns 6,
  pure (n2 + n5 + n7)

/-!

Programming with state is also monadic.

`action σ α` is the type of functions that take in a state of type `σ`
and produce a value of type `α`, along with a possibly updated state.
-/

def action (σ α : Type) : Type :=
σ → α × σ

def action.read {σ : Type} : action σ σ :=
λ s, (s, s)

def action.write {σ : Type} (s : σ) : action σ unit :=
λ _, ((), s)

def action.pure {σ α : Type} (a : α) : action σ α :=
λ s, (a, s)

def action.bind {σ : Type} {α β : Type} (ma : action σ α)
    (f : α → action σ β) :
  action σ β :=
λ s, match ma s with
| (a, s') := f a s'
end

@[instance] def action.monad {σ : Type} :
  monad (action σ) :=
{ pure       := @action.pure σ,
  bind       := @action.bind σ }

def nat_action : action ℕ string :=
do
  first_val ← action.read,
  action.write (first_val * 2),
  new_val ← action.read,
  pure (to_string first_val ++ " ---> " ++ to_string new_val)

#eval nat_action 3

/-!

## The tactic monad

tactic α := tactic_state → result tactic_state α

A tactic can read and/or modify the tactic state, and either succeeds
(producing a value of type α) or fails with an exception message.

-/

open tactic

#print tactic
#print result

meta def my_first_tactic : tactic unit :=
do
  l ← local_context,
  trace l

meta def show_true : tactic unit :=
do tactic.applyc `trivial

example (a b c : ℕ) (h : a + b + c = 0) : true :=
begin
  my_first_tactic,
  show_true
end

run_cmd my_first_tactic

meta def apply_and : tactic unit :=
do
  trace "applying and.intro",
  applyc `and.intro

example : true ∧ true :=
begin
  apply_and,
  show_true, show_true
end

meta def apply_and_or_intro : tactic unit :=
do applyc `and.intro <|>
do intro `nv, skip

example : false → true ∧ true :=
begin
  apply_and_or_intro,
  apply_and_or_intro,
  show_true, show_true
end

meta def my_repeat : tactic unit → tactic unit :=
λ t, (do t, my_repeat t) <|> skip

example : false → true ∧ true :=
begin
  my_repeat apply_and_or_intro,
  my_repeat show_true
end

/-!

## Built-in data types

To be properly "meta," our tactics should be able to express
and manipulate Lean programs (= terms).
We see these in Lean as traditional data types. But, like `tactic_state`
and others, the runtime representation of these is different.

-/

#check declaration
#check tactic.get_decl

#check name
#print name

#check `nat
#check `nat.succ

#print prefix name

#check expr
#print expr

#check expr.to_raw_fmt

open tactic

run_cmd do
  d ← get_decl `nat.succ,
  trace d.type.to_raw_fmt

/-!

A closed expression (e.g. the type or body of a declaration in the environment)
should have no occurrences of `local_const` or `mvar`.
`elet` and `macro` can always be expanded.

Bound variables (`var`) are indexed by natural numbers, not names!
The names and types are stored in the binders (`lam` or `pi`).
`var 0` refers to "the variable bound by the closest binder."
`var 1` refers to "the variable bound by the second-closest binder."
And so on.

But often we aren't dealing with closed expressions.
If we get the type of the goal in the middle of a proof, it will probably refer
to things in the local context.
These are represented as local constants, `local_const`.
They have a unique name, pretty-printing name, binder info, and type.

-/

meta def expr.local_unique_name : expr → name
| (expr.local_const nm ppnm bi tp) := nm
| _ := default

example (a a a : ℕ) : true := by do
  lc ← local_context,
  trace lc,
  trace (lc.map expr.local_unique_name),
  triv

/-!

Things that are already defined in our environment can be accessed as `const`s.
A `const` has a name and list of universe parameters.

Often we won't build these by hand, but use `tactic.mk_const`.
-/

#check expr.const `nat []
run_cmd do
  e ← mk_const `nat,
  trace e.to_raw_fmt

/-!
Building expressions by hand is rather cumbersome. There are ways around this.
`tactic.mk_app` will fill in implicit arguments for you.
-/

#check tactic.mk_app

run_cmd do
  z ← mk_const `nat.zero,
  a ← mk_app `nat.add [z, z],
  trace a,
  if a = z then trace "eq" else trace "neq"

/-!
We can also write *quoted* expressions, like quoted names.
-/

#check `(0 + 0)

/-!
We can insert expressions into quoted expressions using antiquotes:
-/

meta def trace_add_expr (e : expr) : tactic unit :=
trace `(0 + %%e)

run_cmd trace_add_expr `(44)

run_cmd trace_add_expr `(nat)

/-!
Sometimes expr quoting fails. In these cases, we might have to use `pexpr`s.
A pre-expression corresponds to unelaborated, input-level syntax:
implicit arguments have not been filled in yet.

`tactic.to_expr` performs *elaboration*: it turns a `pexpr` into an `expr`.
-/

meta def trace_add_expr'' (e : expr) : tactic unit :=
trace `(%%e + %%e)

meta def trace_add_expr' (e : expr) : tactic unit := do
  e ← to_expr ``(%%e + %%e),
  trace e

run_cmd trace_add_expr' `(44)

run_cmd trace_add_expr' `(nat)

/-!
We can walk through expressions, normally and monadically:
-/

#check @expr.fold

#eval expr.fold `(1 + 0) "" (λ e _ s, s ++ ", " ++ to_string e)

#check @expr.mfold

run_cmd expr.mfold `(1 + 0) () (λ e _ _, tactic.trace e)

/-!
One of the most important operations on `expr` is type inference.
-/

run_cmd do
  t ← infer_type `(λ x : ℕ, x + 1),
  trace t

/-!

*Declarations* are stored in the *environment*.
A declaration is an axiom, constant, theorem, or definition.

-/

#check tactic.get_env
#check environment.fold
#check environment.mfold

run_cmd do
  e ← get_env,
  environment.mfold e () (λ d _, tactic.trace (declaration.to_name d))

/-!
## Working with goals and hypotheses

We already saw the tactic `local_context` for getting hypotheses.
`target` returns the type of the goal.
`get_local` retrieves a single hypothesis by name.
-/

example (a b c : ℕ) (h : a + b = c) : a + c + 0 = a + c + 1 - 1 :=
by do
  lc ← local_context,
  trace lc,
  lc_types ← list.mmap infer_type lc,
  trace lc_types,
  tgt ← target,
  trace tgt,
  admit

/-!
`tactic.assert` adds a new hypothesis, creating a new goal for its proof.

There are lots of variants.
-/

example (a b c : ℕ) : true :=
by do
  ac ← get_local `a,
  bc ← get_local `b,
  tactic.assert `new_hyp `(%%ac + %%bc = 0),
  trace_state,
  admit,
  admit

#check tactic.assert
#check tactic.assertv
#check @tactic.note
#check @tactic.note_anon

/-!

To modify the goal, we have our familiar `apply` tactic,
in a few variants:

-/

#check tactic.apply
#check tactic.applyc
#check tactic.exact

/-!
There are lots of ways to call the simplifier...
-/

#check tactic.simplify
#check tactic.simp_target
#check tactic.simp_hyp

/-!
If you want the familiar begin..end block syntax, there's
yet another form of quotation: e.g.

    `[simp [lemma1, lemma2] at h]

is of type `tactic unit`.
-/

example (a b c : ℕ) (h : a + b = c) : a + c + 0 = a + c + 1 - 1 :=
by do
  lc ← local_context,
  trace lc,
  lc_types ← list.mmap infer_type lc,
  trace lc_types,
  tgt ← target,
  trace tgt,
  `[simp]

/-! ## Example: A Conjuction-Destructing Tactic

We define a `destruct_and` tactic that automates the elimination of `∧` in
premises, automating proofs such as these: -/

lemma abcd_a (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  a :=
and.elim_left h

lemma abcd_b (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b :=
and.elim_left (and.elim_left (and.elim_right h))

lemma abcd_bc (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ c :=
and.elim_left (and.elim_right h)

/-! Our tactic relies on a helper metafunction, which takes as argument the
hypothesis `h` to use as an expression rather than as a name: -/

meta def destruct_and_helper : expr → tactic unit
| h :=
  do
    t ← tactic.infer_type h,
    match t with
    | `(%%a ∧ %%b) :=
      tactic.exact h
      <|>
      do {
        ha ← tactic.to_expr ``(and.elim_left %%h),
        destruct_and_helper ha }
      <|>
      do {
        hb ← tactic.to_expr ``(and.elim_right %%h),
        destruct_and_helper hb }
    | _            := tactic.exact h
    end

meta def tactic.destruct_and (nam : name) : tactic unit :=
do
  h ← tactic.get_local nam,
  destruct_and_helper h

/-! Let us check that our tactic works: -/

lemma abc_a (a b c : Prop) (h : a ∧ b ∧ c) :
  a :=
by tactic.destruct_and `h

lemma abc_b (a b c : Prop) (h : a ∧ b ∧ c) :
  b :=
by tactic.destruct_and `h

lemma abc_bc (a b c : Prop) (h : a ∧ b ∧ c) :
  b ∧ c :=
by tactic.destruct_and `h

lemma abc_ac (a b c : Prop) (h : a ∧ b ∧ c) :
  a ∧ c :=
by destruct_and `h   -- fails

/-!
## Interactive parsing

Writing
    destruct_and `h
with the quoted name `h` is ugly. We don't want to do this in our tactic proofs.
And indeed, most of the time, we don't have to:
there's no quoting in `apply h`, `simp [h]`, etc.

There's some trickery going on here at the parser level.
`begin...end` and `by` blocks are parsed in "interactive tactic mode."
When we wrote `by destruct_and` above, Lean first looked for a declaration
called `tactic.interactive.destruct_and`. When it failed to find such a tactic,
it fell back on resolving `destruct_and` in the normal way.
-/

#check @tactic.apply
#check @tactic.interactive.apply

/-!
Instead of taking arguments of type `expr`, `name`, etc., interactive mode tactics
take parser commands.

`setup_tactic_parser` is equivalent to
```
open _root_.lean
open _root_.lean.parser
open _root_.interactive _root_.interactive.types
local postfix `?`:9001 := optional
local postfix *:9001 := many .
```
-/

section interactive_mode

setup_tactic_parser

meta def _root_.tactic.interactive.destruct_and (h : parse ident) : tactic unit :=
tactic.destruct_and h

/-!
`parse ident` is definitionally equal to `name`, but in interactive mode,
we can write it unquoted.
We put this in the `_root_` namespace to escape the `LoVe` namespace.
-/

lemma abc_bc' (a b c : Prop) (h : a ∧ b ∧ c) :
  b ∧ c :=
by destruct_and h

#check parse parser.pexpr
#check parse pexpr_list
#check parse ident*
#check parse ident?

end interactive_mode

meta def tactic.destruct_and_anon : tactic unit :=
do
  lc ← local_context,
  lc.mfirst (λ h, destruct_and_helper h)

section interactive_mode

setup_tactic_parser

meta def _root_.tactic.interactive.destruct_and' (h : parse ident?) : tactic unit :=
match h with
| some h' := tactic.destruct_and h'
| none    := tactic.destruct_and_anon
end

lemma abc_bc'' (a b c : Prop) (h : a ∧ b ∧ c) :
  b ∧ c :=
by destruct_and'

/-!
Interactive-mode tactics are *always* `tactic unit`.
-/

end interactive_mode

/-!

## Goal management

We know that tactics ultimately need to build a proof term.
How does this actually happen?

At the beginning of a begin...end block where the goal is to prove `T`,
Lean creates a *metavariable* `?m1 : T`.
Tactics that update the goal, like `applyc`,
(partially) assign values to the goal metavariable.
These values can contain new metavariables.

-/

example : true ∧ false :=
by do
  gs ← get_goals,
  trace gs,
  trace (gs.map expr.to_raw_fmt),
  gs' ← gs.mmap infer_type,
  trace gs',
  let orig_goal := gs.head,
  trace "------",

  applyc `and.intro,

  gs ← get_goals,
  trace gs,
  trace (gs.map expr.to_raw_fmt),
  gs' ← gs.mmap infer_type,
  trace gs',
  trace "------",

  orig_goal ← instantiate_mvars orig_goal,
  trace orig_goal.to_raw_fmt

/-!
`get_goals` returns a list of metavariables (of type `epxr`),
representing the remaining proof obligations.
*Unifying* these metavariables with other terms will create partial assignments.

(This is a very low-level technique, we don't usually do this in practice!)
-/

example : true :=
by do
  [g] ← get_goals,
  trace g,
  unify g `(trivial),
  gs ← get_goals,
  trace gs,
  set_goals [],
  gs ← get_goals,
  trace gs

/-!
Note that this can also get us in "trouble": we can tell the system we've
finished a proof when we really haven't.
-/

meta def _root_.tactic.interactive.oops : tactic unit :=
do
  mv ← mk_meta_var `(true),
  set_goals [mv]

example : false :=
begin
  oops,
  trivial,
end

/-!

Metavariable assignments are stored in the tactic state.
So the ultimate goal of a begin...end block is:
"write a function tactic_state → tactic_state that assigns the initial goal
metavariable to a term that does not contain any metavariables."

-/

/-!

## Proof by reflection

YOu may have noticed that we can't prove anything about the tactics we write.
But there's a middle ground: sometimes with a bit of meta "wrapper code,"
we can turn proofs about syntax-like operations into actual proof terms.

The general strategy looks like this:
* represent the syntax of some class of formulas in (non-meta) Lean
* define an interpretation function from these formulas to Prop
* define some operation on this syntax, and prove it correct with respect to the interpretation
* write a small bit of meta code that turns a goal into a statement about your reflected syntax

The idea is that the goal left after applying your correctness theorem can be proved by computation.

This is commonly used for evaluation or normalization functions.
`ring`, for example, can be implemented by defining the syntax of ring expressions
and verifying a normalization algorithm:
if
`ring_syntax : Type`,
`interp {α : Type} [ring α] : ring_syntax → α`,
`normalize : ring_syntax → ring_syntax`, then
`∀ r1 r2 : ring_syntax, interp r1 = interp r2 ↔ normalize r1 = normalize r2`.

The meta code looks at a goal `c + a*b = b*a + c`,
constructs `ring_syntax` objects `r1` and `r2` representing both sides,
and changes the goal to showing that `normalize r1 = normalize r2`.
This can be proved by `refl`.

-/

inductive bexpr
| atom : bool → bexpr
| and : bexpr → bexpr → bexpr
| or : bexpr → bexpr → bexpr
| imp : bexpr → bexpr → bexpr
| not : bexpr → bexpr

open bexpr

def interp : bexpr → Prop
| (atom tt) := true
| (atom ff) := false
| (and a b) := interp a ∧ interp b
| (or a b) := interp a ∨ interp b
| (imp a b) := interp a → interp b
| (not b) := ¬ interp b

def normalize : bexpr → bool
| (atom b) := b
| (and a b) := normalize a && normalize b
| (or a b) := normalize a || normalize b
| (imp a b) := (bnot (normalize a)) || normalize b
| (not b) := bnot (normalize b)

theorem normalize_correct (b : bexpr) : normalize b = tt ↔ interp b :=
begin
  induction' b; try {simp [normalize, interp] at *},
  case and : { finish },
  case or : { finish },
  case not : { simpa using not_iff_not.mpr ih },
  case atom: { cases b; simp [normalize, interp] },
  case imp :
  { have h_not : normalize b = ff ↔ ¬ interp b := by simpa using not_iff_not.mpr ih_b,
    finish },
end

meta def bexpr_of_expr : expr → option expr
| `(true) := some `(bexpr.atom tt)
| `(false) := some `(bexpr.atom ff)
| `(%%a ∧ %%b) := do a ← bexpr_of_expr a, b ← bexpr_of_expr b, some `(bexpr.and %%(a) %%(b))
| `(%%a ∨ %%b) := do a ← bexpr_of_expr a, b ← bexpr_of_expr b, some `(bexpr.or %%(a) %%(b))
| `(%%a → %%b) := do a ← bexpr_of_expr a, b ← bexpr_of_expr b, some `(bexpr.imp %%(a) %%(b))
| `(¬ %%a) := do a ← bexpr_of_expr a, some `(bexpr.not %%(a))
| _ := none

meta def _root_.tactic.interactive.change_goal : tactic unit :=
do
  t ← target,
  match bexpr_of_expr t with
  | some t' := do apply `(iff.mp (normalize_correct %%(t'))), skip
  | none := fail "goal is not a bexpr pattern"
  end

example : (true → true) ∨ false :=
begin
  change_goal,
  refl
end

/-!
You could imagine doing the same with, say, a SAT solver.

Modify `bexpr` to cover all propositional formulas: `atom : ℕ → bexpr`.
Add an argument to `interp`: `dict : ℕ → Prop` assigning atoms to propositions.
`normalize` becomes `is_tautology : bexpr → bool`.
`normalize_correct` becomes
  `is_tautology_correct (b : bexpr) : is_tautology b = tt ↔ ∀ dict, interp dict b`
`bexpr_of_expr` will also have to return a dictionary.

-/

end LoVe