import Iris.BI
import Iris.Proofmode.Classes
import Iris.Proofmode.Environments
import Iris.Std

namespace Iris.Proofmode
open Iris.BI Iris.Std
open BI

/-- Introduce one or multiple let-bound variables. -/
scoped macro "intro_let " names:(colGt Lean.binderIdent)* : tactic => `(
  intro _ ;
  split ;
  rename_i $[$names]*
)

-- proof mode
theorem tac_start [BI PROP] (P : PROP) :
  envs_entails ⟨.nil, .nil⟩ P →
  ⊢ P
:= by
  simp only [envs_entails, of_envs, big_op]
  rw' [intuitionistically_True_emp, (left_id : emp ∗ _ ⊣⊢ _)]
  intro h
  exact h

theorem tac_stop [BI PROP] {Γₚ Γₛ : Env PROP} (P : PROP) :
  let Ps := match Γₚ, Γₛ with
    | .nil, .nil => `[iprop| emp]
    | _   , .nil => `[iprop| □ [∧] Γₚ]
    | .nil, _    => `[iprop| [∗] Γₛ]
    | _   , _    => `[iprop| □ [∧] Γₚ ∗ [∗] Γₛ]
  (Ps ⊢ P) →
  envs_entails ⟨Γₚ, Γₛ⟩ P
:= by
  cases Γₚ
  <;> cases Γₛ
  all_goals
    simp [envs_entails, of_envs, big_op]
    intro Ps
    rw' [Ps]
  case cons.nil =>
    rw' [(right_id : _ ∗ emp ⊣⊢ _)]
  all_goals
    rw' [intuitionistically_True_emp, (left_id : emp ∗ _ ⊣⊢ _)]

theorem tac_clear [BI PROP] {Δ : Envs PROP} (i : EnvsIndex.of Δ) (Q : PROP) :
  let (p, P) := Δ.lookup i
  [TCIte p TCTrue (TCOr (Affine P) (Absorbing Q))] →
  envs_entails (Δ.delete true i) Q →
  envs_entails Δ Q
:= by
  intro_let p P h_lookup
  intro inst_affine_absorbing
  cases p
  all_goals
    cases inst_affine_absorbing
    simp only [envs_entails]
    intro h_entails
    rw' [envs_lookup_delete_sound true h_lookup, h_entails]
    simp only [bi_intuitionistically_if, ite_true, ite_false]
    rw' [sep_elim_r]

-- pure
theorem tac_pure_intro [BI PROP] {Δ : Envs PROP} {a : Bool} {φ : Prop} (Q : PROP) :
  [FromPure a Q φ] →
  [TCIte a (AffineEnv Δ.spatial) TCTrue] →
  φ →
  envs_entails Δ Q
:= by
  simp only [envs_entails]
  intro _ inst_affine_env hφ
  rw' [← from_pure]
  cases a
  case false =>
    apply pure_intro
    exact hφ
  case true =>
    cases inst_affine_env
    simp only [of_envs, bi_affinely_if]
    rw' [
      affine,
      pure_True hφ,
      affinely_True_emp,
      affinely_emp]

-- implication and wand
theorem tac_impl_intro [BI PROP] {Δ : Envs PROP} {P Q : PROP} (R : PROP) :
  [FromImpl R P Q] →
  [TCIte Δ.spatial.isEmpty TCTrue (Persistent P)] →
  [FromAffinely P' P] →
  envs_entails (Δ.append false P') Q →
  envs_entails Δ R
:= by
  simp only [envs_entails]
  intro _ inst_pers _ h_entails
  rw' [← from_impl]
  cases h_empty : Δ.spatial.isEmpty
  <;> rw [h_empty] at inst_pers
  <;> cases inst_pers
  case false =>
    apply impl_intro_l
    rw' [
      envs_append_sound false P',
      (from_affinely : <affine>?true P ⊢ _),
      persistent_and_affinely_sep_l_1,
      wand_elim_r,
      h_entails]
  case true =>
    rw' [envs_spatial_is_empty_intuitionistically h_empty]
    apply impl_intro_l
    rw' [
      envs_append_sound false P',
      (from_affinely : <affine>?true P ⊢ _)]
    simp only [bi_intuitionistically]
    rw' [
      ← affinely_and_lr,
      persistently_and_intuitionistically_sep_r,
      intuitionistically_elim,
      wand_elim_r,
      h_entails]

theorem tac_impl_intro_intuitionistic [BI PROP] {Δ : Envs PROP} {P P' Q : PROP} (R : PROP) :
  [FromImpl R P Q] →
  [IntoPersistent false P P'] →
  envs_entails (Δ.append true P') Q →
  envs_entails Δ R
:= by
  simp only [envs_entails]
  intro _ _ h_entails
  rw' [← from_impl, envs_append_sound true P'] ; simp only
  apply impl_intro_l
  rw' [
    persistently_if_intro_false P,
    into_persistent,
    persistently_and_intuitionistically_sep_l,
    wand_elim_r,
    h_entails]

theorem tac_impl_intro_drop [BI PROP] {Δ : Envs PROP} {P Q : PROP} (R : PROP) :
  [FromImpl R P Q] →
  envs_entails Δ Q →
  envs_entails Δ R
:= by
  simp only [envs_entails]
  intro _ h_entails
  rw' [← from_impl]
  apply impl_intro_l
  rw' [and_elim_r, h_entails]

theorem tac_wand_intro [BI PROP] {Δ : Envs PROP} {P Q : PROP} (R : PROP) :
  [FromWand R P Q] →
  envs_entails (Δ.append false P) Q →
  envs_entails Δ R
:= by
  simp only [envs_entails]
  intro _ h_entails
  rw' [
    ← from_wand,
    envs_append_sound false P,
    h_entails]

theorem tac_wand_intro_intuitionistic [BI PROP] {Δ : Envs PROP} {P P' Q : PROP} (R : PROP) :
  [FromWand R P Q] →
  [IntoPersistent false P P'] →
  [TCOr (Affine P) (Absorbing Q)] →
  envs_entails (Δ.append true P') Q →
  envs_entails Δ R
:= by
  simp only [envs_entails]
  intro _ _ inst_affine_absorbing h_entails
  rw' [← from_wand, envs_append_sound true P'] ; simp only
  apply wand_intro_l
  cases inst_affine_absorbing
  case a.l =>
    rw' [
      ← affine_affinely P,
      persistently_if_intro_false P,
      into_persistent,
      wand_elim_r,
      h_entails]
  case a.r =>
    rw' [
      persistently_if_intro_false P,
      into_persistent,
      ← absorbingly_intuitionistically_into_persistently,
      absorbingly_sep_l,
      wand_elim_r,
      h_entails,
      absorbing]

-- specialize
theorem tac_specialize [BI PROP] {Δ : Envs PROP} (rpPremise rpWand : Bool) (i j : EnvsIndex.of Δ) (h_ne : i.type = j.type → i.val ≠ j.val) {P2 : PROP} (R : PROP) :
  let (p, P1) := Δ.lookup i
  let Δ' := Δ.delete rpPremise i
  let j' := Δ.updateIndexAfterDelete rpPremise i j h_ne
  let (q, Q) := Δ'.lookup j'
  [IntoWand q p Q P1 P2] →
  envs_entails (Δ'.replace rpWand j' (p && q) P2) R →
  envs_entails Δ R
:= by
  intro_let p P1 h_lookup_i
  intro Δ' j'
  intro_let q Q h_lookup_j'
  simp only [envs_entails]
  intro _ h_entails
  rw' [
    envs_lookup_delete_sound rpPremise h_lookup_i,
    envs_lookup_replace_sound rpWand (p && q) P2 h_lookup_j']
  cases p
  case false =>
    rw' [(IntoWand.into_wand : □?q Q ⊢ □?false P1 -∗ P2)]
    simp only [bi_intuitionistically_if, Bool.false_and, ite_false]
    rw' [(assoc : P1 ∗ _ ⊣⊢ _), !wand_elim_r, h_entails]
  case true =>
    simp only [Bool.true_and, ← intuitionistically_if_intro_true]
    rw' [
      ← intuitionistically_idemp,
      ← intuitionistically_if_idemp,
      intuitionistically_intuitionistically_if q,
      (IntoWand.into_wand : □?q Q ⊢ □?true P1 -∗ P2),
      (assoc : □?q □ P1 ∗ _ ⊣⊢ _),
      intuitionistically_if_sep_2,
      !wand_elim_r,
      h_entails]

theorem tac_specialize_forall [BI PROP] {Δ : Envs PROP} (rpWand : Bool) (i : EnvsIndex.of Δ) {Φ : α → PROP} (Q : PROP) :
  let (p, P) := Δ.lookup i
  [IntoForall P Φ] →
  (∃ x, envs_entails (Δ.replace rpWand i p (Φ x)) Q) →
  envs_entails Δ Q
:= by
  intro_let p P h_lookup
  simp only [envs_entails]
  intro _ ⟨x, h_entails⟩
  rw' [
    envs_lookup_replace_sound rpWand p (Φ x) h_lookup,
    IntoForall.into_forall,
    forall_elim x,
    wand_elim_r,
    h_entails]

-- forall
theorem tac_forall_intro [BI PROP] {Δ : Envs PROP} {Ψ : α → PROP} (Q : PROP) :
  [FromForall Q Ψ] →
  (∀ a, envs_entails Δ `[iprop| Ψ a]) →
  envs_entails Δ Q
:= by
  simp only [envs_entails]
  intro _ h_entails
  rw' [← from_forall]
  apply forall_intro
  exact h_entails

-- exist
theorem tac_exist [BI PROP] {Δ : Envs PROP} {Φ : α → PROP} (P : PROP) :
  [FromExist P Φ] →
  (∃ a, envs_entails Δ `[iprop| Φ a]) →
  envs_entails Δ P
:= by
  simp only [envs_entails]
  intro _ ⟨a, h_entails⟩
  rw' [← from_exist, ← exist_intro a, h_entails]

theorem tac_exist_destruct [BI PROP] {Δ : Envs PROP} (i : EnvsIndex.of Δ) {Φ : α → PROP} (Q : PROP) :
  let (p, P) := Δ.lookup i
  [IntoExist P Φ] →
  (∀ a, envs_entails (Δ.replace true i p (Φ a)) Q) →
  envs_entails Δ Q
:= by
  intro_let p P h_lookup
  simp only [envs_entails, Envs.replace]
  intro _ h_entails
  rw' [
    envs_lookup_delete_sound true h_lookup,
    into_exist,
    intuitionistically_if_exist,
    sep_exist_r] ; simp only
  apply exist_elim
  intro a
  rw' [
    envs_append_sound p (Φ a),
    wand_elim_r,
    h_entails a]

-- emp
theorem tac_emp_intro [BI PROP] {Γₚ Γₛ : Env PROP} :
  [AffineEnv Γₛ] →
  envs_entails ⟨Γₚ, Γₛ⟩ `[iprop| emp]
:= by
  intro _
  simp only [envs_entails, of_envs]
  rw' [
    affinely_elim_emp,
    (affine : [∗] Γₛ.toList ⊢ emp),
    (left_id : emp ∗ _ ⊣⊢ _)]

-- assumptions
theorem tac_assumption_lean [BI PROP] {Δ : Envs PROP} {P : PROP} (Q : PROP) :
  (⊢ P) →
  [FromAssumption true P Q] →
  [TCIte Δ.spatial.isEmpty TCTrue (TCOr (Absorbing Q) (AffineEnv Δ.spatial))] →
  envs_entails Δ Q
:= by
  simp only [envs_entails]
  intro h_P _ inst_absorbing_affine_env
  rw' [
    ← (left_id : emp ∗ of_envs Δ ⊣⊢ _),
    ← intuitionistically_emp,
    h_P,
    (from_assumption : □?true P ⊢ Q)]
  cases h_empty : Δ.spatial.isEmpty
  <;> rw [h_empty] at inst_absorbing_affine_env
  <;> cases inst_absorbing_affine_env
  case false.e inst_absorbing_affine_env =>
    cases inst_absorbing_affine_env
    <;> rw' [!sep_elim_l]
  case true.t =>
    rw' [envs_spatial_is_empty_intuitionistically h_empty, sep_elim_l]

theorem tac_assumption [BI PROP] {Δ : Envs PROP} (i : EnvsIndex.of Δ) (Q : PROP) :
  let (p, P) := Δ.lookup i
  [FromAssumption p P Q] →
  let Δ' := Δ.delete true i
  [TCIte Δ'.spatial.isEmpty TCTrue (TCOr (Absorbing Q) (AffineEnv Δ'.spatial))] →
  envs_entails Δ Q
:= by
  intro_let p P h_lookup
  simp only [envs_entails]
  intro _ inst_absorbing_affine_env
  rw' [envs_lookup_delete_sound true h_lookup]
  cases h_empty : (Δ.delete true i).spatial.isEmpty
  <;> rw [h_empty] at inst_absorbing_affine_env
  <;> cases inst_absorbing_affine_env
  case false.e inst_absorbing_affine_env =>
    rw' [(from_assumption : □?p P ⊢ Q)]
    cases inst_absorbing_affine_env
    <;> rw' [!sep_elim_l]
  case true.t =>
    rw' [envs_spatial_is_empty_intuitionistically h_empty, sep_elim_l]
    exact from_assumption

-- false
theorem tac_ex_falso [BI PROP] {Δ : Envs PROP} (Q : PROP) :
  envs_entails Δ `[iprop| False] →
  envs_entails Δ Q
:= by
  simp only [envs_entails]
  intro h_entails
  rw' [h_entails]
  exact False_elim

theorem tac_false_destruct [BI PROP] {Δ : Envs PROP} (i : EnvsIndex.of Δ) (Q : PROP) :
  let (_, P) := Δ.lookup i
  P = `[iprop| False] →
  envs_entails Δ Q
:= by
  intro_let p P h_lookup
  simp only [envs_entails]
  intro h_false
  rw' [
    envs_lookup_delete_sound true h_lookup,
    intuitionistically_if_elim,
    h_false,
    sep_elim_l]
  exact False_elim

-- moving between contexts
theorem tac_pure [BI PROP] {Δ : Envs PROP} {φ : Prop} (i : EnvsIndex.of Δ) (Q : PROP) :
   let (p, P) := Δ.lookup i
  [IntoPure P φ] →
  [TCIte p TCTrue (TCOr (Affine P) (Absorbing Q))] →
  (φ → envs_entails (Δ.delete true i) Q) →
  envs_entails Δ Q
:= by
  intro_let p P h_lookup
  simp only [envs_entails]
  intro _ inst_affine_absorbing h_entails
  rw' [envs_lookup_delete_sound true h_lookup]
  cases p
  <;> simp only [bi_intuitionistically_if, ite_true, ite_false]
  <;> cases inst_affine_absorbing
  case false.e inst_affine_absorbing =>
    cases inst_affine_absorbing
    case l =>
      rw' [
        ← affine_affinely P,
        into_pure,
        ← persistent_and_affinely_sep_l]
      apply pure_elim φ
      · exact and_elim_l
      · intro h_φ
        rw' [h_entails h_φ, and_elim_r]
    case r =>
      rw' [
        into_pure,
        persistent_absorbingly_affinely_2,
        absorbingly_sep_lr,
        ← persistent_and_affinely_sep_l]
      apply pure_elim_l
      intro h_φ
      rw' [h_entails h_φ, absorbing]
  case true.t =>
    rw' [
      into_pure,
      ← persistently_and_intuitionistically_sep_l,
      persistently_pure]
    apply pure_elim_l
    intro h_φ
    rw' [h_entails h_φ]

theorem tac_intuitionistic [BI PROP] {Δ : Envs PROP} {P' : PROP} (i : EnvsIndex.of Δ) (Q : PROP) :
  let (p, P) := Δ.lookup i
  [IntoPersistent p P P'] →
  [TCIte p TCTrue (TCOr (Affine P) (Absorbing Q))] →
  envs_entails (Δ.replace true i true P') Q →
  envs_entails Δ Q
:= by
  intro_let p P h_lookup
  simp only [envs_entails]
  intro _ inst_affine_absorbing h_entails
  rw' [envs_lookup_replace_sound true true P' h_lookup]
  cases p
  <;> simp only [bi_intuitionistically_if, ite_true, ite_false, bi_intuitionistically]
  <;> cases inst_affine_absorbing
  case false inst_affine_absorbing =>
    cases inst_affine_absorbing
    case l =>
      rw' [
        ← affine_affinely P,
        persistently_if_intro_false P,
        into_persistent,
        wand_elim_r,
        h_entails]
    case r =>
      rw' [persistently_if_intro_false P, into_persistent]
      conv =>
        lhs
        lhs
        rw [← absorbingly_intuitionistically_into_persistently]
      rw' [
        absorbingly_sep_l,
        wand_elim_r,
        h_entails,
        absorbing]
  case true =>
    rw' [
      persistently_if_intro_true P,
      into_persistent,
      wand_elim_r,
      h_entails]

theorem tac_spatial [BI PROP] {Δ : Envs PROP} {P' : PROP} (i : EnvsIndex.of Δ) (Q : PROP) :
  let (p, P) := Δ.lookup i
  [FromAffinely P' P p] →
  envs_entails (Δ.replace true i false P') Q →
  envs_entails Δ Q
:= by
  intro_let p P h_lookup
  simp only [envs_entails]
  intro _ h_entails
  rw' [envs_lookup_replace_sound true false P' h_lookup]
  cases p
  <;> simp only [bi_intuitionistically_if, ite_true, ite_false]
  case false =>
    rw' [
      affinely_if_intro_false P,
      from_affinely,
      wand_elim_r,
      h_entails]
  case true =>
    rw' [
      intuitionistically_affinely,
      affinely_if_intro_true P,
      from_affinely,
      wand_elim_r,
      h_entails]

-- (separating) conjunction splitting
theorem tac_and_split [BI PROP] {Δ : Envs PROP} {Q1 Q2 : PROP} (P : PROP) :
  [FromAnd P Q1 Q2] →
  envs_entails Δ Q1 →
  envs_entails Δ Q2 →
  envs_entails Δ P
:= by
  simp only [envs_entails]
  intro _ h_entails_1 h_entails_2
  rw' [← from_and]
  apply and_intro
  · exact h_entails_1
  · exact h_entails_2

theorem tac_sep_split [BI PROP] {Δ : Envs PROP} {Q1 Q2 : PROP} (mask : List Bool) (h : mask.length = Δ.spatial.length) (P : PROP) :
  let (Δ₁, Δ₂) := Δ.split mask h
  [FromSep P Q1 Q2] →
  envs_entails Δ₁ Q1 →
  envs_entails Δ₂ Q2 →
  envs_entails Δ P
:= by
  intro_let Δ₁ Δ₂ h_split
  simp only [envs_entails]
  intro _ h_entails_1 h_entails_2
  rw' [
    envs_split_sound h_split,
    ← from_sep,
    h_entails_1,
    h_entails_2]

-- disjunction selection
theorem tac_disjunction_l [BI PROP] {Δ : Envs PROP} {Q1 Q2 : PROP} (P : PROP) :
  [FromOr P Q1 Q2] →
  envs_entails Δ Q1 →
  envs_entails Δ P
:= by
  simp only [envs_entails]
  intro _ h_entails
  rw' [← from_or]
  apply or_intro_l'
  exact h_entails

theorem tac_disjunction_r [BI PROP] {Δ : Envs PROP} {Q1 Q2 : PROP} (P : PROP) :
  [FromOr P Q1 Q2] →
  envs_entails Δ Q2 →
  envs_entails Δ P
:= by
  simp only [envs_entails]
  intro _ h_entails
  rw' [← from_or]
  apply or_intro_r'
  exact h_entails

-- destruction
class inductive IntoConjunction [BI PROP] (P : PROP) (P1 P2 : outParam PROP) : Bool → Type
  | and : [IntoAnd true P P1 P2] → IntoConjunction P P1 P2 true
  | sep : [IntoSep P P1 P2] → IntoConjunction P P1 P2 false

attribute [instance] IntoConjunction.and
attribute [instance] IntoConjunction.sep

theorem tac_conjunction_destruct [BI PROP] {Δ : Envs PROP} {P1 P2 : PROP} (i : EnvsIndex.of Δ) (Q : PROP) :
  let (p, P) := Δ.lookup i
  [IntoConjunction P P1 P2 p] →
  envs_entails (Δ |>.delete true i |>.append p P1 |>.append p P2) Q →
  envs_entails Δ Q
:= by
  intro_let p P h_lookup
  simp only [envs_entails]
  intro inst_conjunction h_entails
  rw' [
    envs_lookup_delete_sound true h_lookup,
    envs_append_sound p P1,
    envs_append_sound p P2] ; simp only
  cases p
  <;> simp only [bi_intuitionistically_if, ite_true, ite_false]
  <;> cases inst_conjunction
  case false.sep =>
    rw' [
      into_sep,
      (comm : P1 ∗ P2 ⊣⊢ _),
      ← (assoc : _ ⊣⊢ (P2 ∗ P1) ∗ _),
      wand_elim_r,
      wand_elim_r,
      h_entails]
  case true.and =>
    rw' [intuitionistically_if_intro_true P, into_and]
    simp only [bi_intuitionistically_if, ite_true]
    rw' [
      intuitionistically_and,
      and_sep_intuitionistically,
      (comm : □ P1 ∗ □ P2 ⊣⊢ _),
      ← (assoc : _ ⊣⊢ (□ P2 ∗ □ P1) ∗ _),
      wand_elim_r,
      wand_elim_r,
      h_entails]

theorem tac_conjunction_destruct_choice [BI PROP] {Δ : Envs PROP} {P1 P2 : PROP} (i : EnvsIndex.of Δ) (d : Bool) (Q : PROP) :
  let (p, P) := Δ.lookup i
  [IntoAnd p P P1 P2] →
  envs_entails (if d then Δ.replace true i p P1 else Δ.replace true i p P2) Q →
  envs_entails Δ Q
:= by
  intro_let p P h_lookup
  simp only [envs_entails]
  intro _ h_entails
  cases d
  case false =>
    rw' [
      envs_lookup_replace_sound true p P2 h_lookup,
      into_and,
      and_elim_r,
      wand_elim_r,
      h_entails]
  case true =>
    rw' [
      envs_lookup_replace_sound true p P1 h_lookup,
      into_and,
      and_elim_l,
      wand_elim_r,
      h_entails]

theorem tac_disjunction_destruct [BI PROP] {Δ : Envs PROP} {P1 P2 : PROP} (i : EnvsIndex.of Δ) (Q : PROP) :
  let (p, P) := Δ.lookup i
  [IntoOr P P1 P2] →
  envs_entails (Δ.replace true i p P1) Q →
  envs_entails (Δ.replace true i p P2) Q →
  envs_entails Δ Q
:= by
  intro_let p P h_lookup
  simp only [envs_entails]
  intro _ h_entails_1 h_entails_2
  rw' [envs_lookup_delete_sound true h_lookup] ; simp only
  simp only [Envs.replace] at h_entails_1
  simp only [Envs.replace] at h_entails_2
  rw' [into_or, intuitionistically_if_or, sep_or_r]
  apply or_elim
  · rw' [envs_append_sound p P1, wand_elim_r, h_entails_1]
  · rw' [envs_append_sound p P2, wand_elim_r, h_entails_2]

end Iris.Proofmode


inductive A : Type
| ctor : A → A
| inh

-- set_option trace.Elab true in
def f : A → A → Bool
| banana, a b | _, lol how => 1 + "test" + f1 -- Error
| _, _ => false

def g : A → A → Bool
| A.inh, _ | _, A.inh => true
| _, _ => false

example : g .inh (.ctor a) = true := rfl
example : g .inh .inh = true := rfl
example : g (.ctor a) .inh = true := rfl
example : g (.ctor a) (.ctor b) = false := rfl


/- Tactic combinators -/

example : p → q → r → p ∧ ((p ∧ q) ∧ r) ∧ (q ∧ r ∧ p) := by
  intros
  repeat (any_goals constructor)
  all_goals assumption

example : p → q → r → p ∧ ((p ∧ q) ∧ r) ∧ (q ∧ r ∧ p) := by
  intros
  repeat (any_goals (first | assumption | constructor))


/-
Copyright (c) E.W.Ayers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.

Author: E.W.Ayers

! This file was ported from Lean 3 source module init.meta.tagged_format
! leanprover-community/mathlib commit aa3b5836dd026e4a02f0bd270ac27f2953880417
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
prelude
import Leanbin.Init.Meta.Tactic
import Leanbin.Init.Meta.ExprAddress
import Leanbin.Init.Control.Default

universe u

/-- An alternative to format that keeps structural information stored as a tag. -/
unsafe inductive tagged_format (α : Type u)
  | tag : α → tagged_format → tagged_format
  | compose : tagged_format → tagged_format → tagged_format
  | Group : tagged_format → tagged_format
  | nest : Nat → tagged_format → tagged_format
  | highlight : Format.Color → tagged_format → tagged_format
  | of_format : format → tagged_format
#align tagged_format tagged_format

namespace TaggedFormat

variable {α β : Type u}

protected unsafe def map (f : α → β) : tagged_format α → tagged_format β
  | compose x y => compose (map x) (map y)
  | Group x => group <| map x
  | nest i x => nest i <| map x
  | highlight c x => highlight c <| map x
  | of_format x => of_format x
  | tag a x => tag (f a) (map x)
#align tagged_format.map tagged_format.map

unsafe instance is_functor : Functor tagged_format where map := @tagged_format.map
#align tagged_format.is_functor tagged_format.is_functor

unsafe def m_untag {t : Type → Type} [Monad t] (f : α → format → t format) :
    tagged_format α → t format
  | compose x y => pure format.compose <*> m_untag x <*> m_untag y
  | Group x => pure format.group <*> m_untag x
  | nest i x => pure (format.nest i) <*> m_untag x
  | highlight c x => pure format.highlight <*> m_untag x <*> pure c
  | of_format x => pure <| x
  | tag a x => m_untag x >>= f a
#align tagged_format.m_untag tagged_format.m_untag

unsafe def untag (f : α → format → format) : tagged_format α → format :=
  @m_untag _ id _ f
#align tagged_format.untag tagged_format.untag

unsafe instance has_to_fmt : has_to_format (tagged_format α) :=
  ⟨tagged_format.untag fun a f => f⟩
#align tagged_format.has_to_fmt tagged_format.has_to_fmt

end TaggedFormat

/-- tagged_format with information about subexpressions. -/
unsafe def eformat :=
  tagged_format (Expr.Address × expr)
#align eformat eformat

/-- A special version of pp which also preserves expression boundary information.

On a tag ⟨e,a⟩, note that the given expr `e` is _not_ necessarily the subexpression of the root
expression that `tactic_state.pp_tagged` was called with. For example if the subexpression is
under a binder then all of the `expr.var 0`s will be replaced with a local constant not in
the local context with the name and type set to that of the binder.-/
unsafe axiom tactic_state.pp_tagged : tactic_state → expr → eformat
#align tactic_state.pp_tagged tactic_state.pp_tagged

unsafe def tactic.pp_tagged : expr → tactic eformat
  | e => tactic.read >>= fun ts => pure <| tactic_state.pp_tagged ts e
#align tactic.pp_tagged tactic.pp_tagged


example {a : α} {as bs : List α} (h : bs = a::as) : as.length + 1 = bs.length := by
  rw [← List.length]
  trace_state -- lhs was folded
  rw [h]

example {a : α} {as bs : List α} (h : as = bs) : (a::b::as).length = bs.length + 2 := by
  rw [List.length, List.length]
  trace_state -- lhs was unfolded
  rw [h]

example {a : α} {as bs : List α} (h : as = bs) : (a::b::as).length = (b::bs).length + 1 := by
  conv => lhs; rw [List.length, List.length]
  trace_state -- lhs was unfolded
  conv => rhs; rw [List.length]
  trace_state -- rhs was unfolded
  rw [h]

example {a : α} {as bs : List α} (h : as = bs) : id (id ((a::b::as).length)) = (b::bs).length + 1 := by
  rw [id]
  trace_state
  rw [id]
  trace_state
  rw [List.length, List.length, List.length]
  trace_state
  rw [h]


import LMT

variable {I} [Nonempty I] {E} [Nonempty E] [Nonempty (A I E)]

example {a1 a2 a3 : A I E} :
        (v1) ≠ (((((a3).write i1 (v1)).write i2 (v1)).write i3 (v1)).read i2) → False := by
  arr


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Simon Hudon, Sébastien Gouëzel, Scott Morrison
-/
import tactic.lint
import tactic.dependencies

open lean
open lean.parser

local postfix `?`:9001 := optional
local postfix *:9001 := many

namespace tactic
namespace interactive
open interactive interactive.types expr

/-- Similar to `constructor`, but does not reorder goals. -/
meta def fconstructor : tactic unit := concat_tags tactic.fconstructor

add_tactic_doc
{ name       := "fconstructor",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.fconstructor],
  tags       := ["logic", "goal management"] }

/-- `try_for n { tac }` executes `tac` for `n` ticks, otherwise uses `sorry` to close the goal.
Never fails. Useful for debugging. -/
meta def try_for (max : parse parser.pexpr) (tac : itactic) : tactic unit :=
do max ← i_to_expr_strict max >>= tactic.eval_expr nat,
  λ s, match _root_.try_for max (tac s) with
  | some r := r
  | none   := (tactic.trace "try_for timeout, using sorry" >> admit) s
  end

/-- Multiple `subst`. `substs x y z` is the same as `subst x, subst y, subst z`. -/
meta def substs (l : parse ident*) : tactic unit :=
propagate_tags $ l.mmap' (λ h, get_local h >>= tactic.subst) >> try (tactic.reflexivity reducible)

add_tactic_doc
{ name       := "substs",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.substs],
  tags       := ["rewriting"] }

/-- Unfold coercion-related definitions -/
meta def unfold_coes (loc : parse location) : tactic unit :=
unfold [
  ``coe, ``coe_t, ``has_coe_t.coe, ``coe_b,``has_coe.coe,
  ``lift, ``has_lift.lift, ``lift_t, ``has_lift_t.lift,
  ``coe_fn, ``has_coe_to_fun.coe, ``coe_sort, ``has_coe_to_sort.coe] loc

add_tactic_doc
{ name       := "unfold_coes",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.unfold_coes],
  tags       := ["simplification"] }

/-- Unfold `has_well_founded.r`, `sizeof` and other such definitions. -/
meta def unfold_wf :=
propagate_tags (well_founded_tactics.unfold_wf_rel; well_founded_tactics.unfold_sizeof)

/-- Unfold auxiliary definitions associated with the current declaration. -/
meta def unfold_aux : tactic unit :=
do tgt ← target,
   name ← decl_name,
   let to_unfold := (tgt.list_names_with_prefix name),
   guard (¬ to_unfold.empty),
   -- should we be using simp_lemmas.mk_default?
   simp_lemmas.mk.dsimplify to_unfold.to_list tgt >>= tactic.change

/-- For debugging only. This tactic checks the current state for any
missing dropped goals and restores them. Useful when there are no
goals to solve but "result contains meta-variables". -/
meta def recover : tactic unit :=
metavariables >>= tactic.set_goals

/-- Like `try { tac }`, but in the case of failure it continues
from the failure state instead of reverting to the original state. -/
meta def continue (tac : itactic) : tactic unit :=
λ s, result.cases_on (tac s)
 (λ a, result.success ())
 (λ e ref, result.success ())

/-- `id { tac }` is the same as `tac`, but it is useful for creating a block scope without
requiring the goal to be solved at the end like `{ tac }`. It can also be used to enclose a
non-interactive tactic for patterns like `tac1; id {tac2}` where `tac2` is non-interactive. -/
@[inline] protected meta def id (tac : itactic) : tactic unit := tac

/--
`work_on_goal n { tac }` creates a block scope for the `n`-goal (indexed from zero),
and does not require that the goal be solved at the end
(any remaining subgoals are inserted back into the list of goals).

Typically usage might look like:
````
intros,
simp,
apply lemma_1,
work_on_goal 2 {
  dsimp,
  simp
},
refl
````

See also `id { tac }`, which is equivalent to `work_on_goal 0 { tac }`.
-/
meta def work_on_goal : parse small_nat → itactic → tactic unit
| n t := do
  goals ← get_goals,
  let earlier_goals := goals.take n,
  let later_goals := goals.drop (n+1),
  set_goals (goals.nth n).to_list,
  t,
  new_goals ← get_goals,
  set_goals (earlier_goals ++ new_goals ++ later_goals)

/--
`swap n` will move the `n`th goal to the front.
`swap` defaults to `swap 2`, and so interchanges the first and second goals.
-/
meta def swap (n := 2) : tactic unit :=
do gs ← get_goals,
   match gs.nth (n-1) with
   | (some g) := set_goals (g :: gs.remove_nth (n-1))
   | _        := skip
   end

add_tactic_doc
{ name       := "swap",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.swap],
  tags       := ["goal management"] }

/-- `rotate` moves the first goal to the back. `rotate n` will do this `n` times. -/
meta def rotate (n := 1) : tactic unit := tactic.rotate n

add_tactic_doc
{ name       := "rotate",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.rotate],
  tags       := ["goal management"] }

/-- Clear all hypotheses starting with `_`, like `_match` and `_let_match`. -/
meta def clear_ : tactic unit := tactic.repeat $ do
  l ← local_context,
  l.reverse.mfirst $ λ h, do
    name.mk_string s p ← return $ local_pp_name h,
    guard (s.front = '_'),
    cl ← infer_type h >>= is_class, guard (¬ cl),
    tactic.clear h

add_tactic_doc
{ name       := "clear_",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.clear_],
  tags       := ["context management"] }

/--
Acts like `have`, but removes a hypothesis with the same name as
this one. For example if the state is `h : p ⊢ goal` and `f : p → q`,
then after `replace h := f h` the goal will be `h : q ⊢ goal`,
where `have h := f h` would result in the state `h : p, h : q ⊢ goal`.
This can be used to simulate the `specialize` and `apply at` tactics
of Coq. -/
meta def replace (h : parse ident?) (q₁ : parse (tk ":" *> texpr)?)
  (q₂ : parse $ (tk ":=" *> texpr)?) : tactic unit :=
do let h := h.get_or_else `this,
  old ← try_core (get_local h),
  «have» h q₁ q₂,
  match old, q₂ with
  | none,   _      := skip
  | some o, some _ := tactic.clear o
  | some o, none   := swap >> tactic.clear o >> swap
  end

add_tactic_doc
{ name       := "replace",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.replace],
  tags       := ["context management"] }

/-- Make every proposition in the context decidable. -/
meta def classical := tactic.classical

add_tactic_doc
{ name       := "classical",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.classical],
  tags       := ["classical logic", "type class"] }

private meta def generalize_arg_p_aux : pexpr → parser (pexpr × name)
| (app (app (macro _ [const `eq _ ]) h) (local_const x _ _ _)) := pure (h, x)
| _ := fail "parse error"

private meta def generalize_arg_p : parser (pexpr × name) :=
with_desc "expr = id" $ parser.pexpr 0 >>= generalize_arg_p_aux

@[nolint def_lemma]
lemma {u} generalize_a_aux {α : Sort u}
  (h : ∀ x : Sort u, (α → x) → x) : α := h α id

/--
Like `generalize` but also considers assumptions
specified by the user. The user can also specify to
omit the goal.
-/
meta def generalize_hyp  (h : parse ident?) (_ : parse $ tk ":")
  (p : parse generalize_arg_p)
  (l : parse location) :
  tactic unit :=
do h' ← get_unused_name `h,
   x' ← get_unused_name `x,
   g ← if ¬ l.include_goal then
       do refine ``(generalize_a_aux _),
          some <$> (prod.mk <$> tactic.intro x' <*> tactic.intro h')
   else pure none,
   n ← l.get_locals >>= tactic.revert_lst,
   generalize h () p,
   intron n,
   match g with
     | some (x',h') :=
        do tactic.apply h',
           tactic.clear h',
           tactic.clear x'
     | none := return ()
   end

add_tactic_doc
{ name       := "generalize_hyp",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.generalize_hyp],
  tags       := ["context management"] }

meta def compact_decl_aux : list name → binder_info → expr → list expr →
  tactic (list (list name × binder_info × expr))
| ns bi t [] := pure [(ns.reverse, bi, t)]
| ns bi t (v'@(local_const n pp bi' t') :: xs) :=
  do t' ← infer_type v',
     if bi = bi' ∧ t = t'
       then compact_decl_aux (pp :: ns) bi t xs
       else do vs ← compact_decl_aux [pp] bi' t' xs,
               pure $ (ns.reverse, bi, t) :: vs
| ns bi t (_ :: xs) := compact_decl_aux ns bi t xs

/-- go from (x₀ : t₀) (x₁ : t₀) (x₂ : t₀) to (x₀ x₁ x₂ : t₀) -/
meta def compact_decl : list expr → tactic (list (list name × binder_info × expr))
| [] := pure []
| (v@(local_const n pp bi t) :: xs)  :=
  do t ← infer_type v,
     compact_decl_aux [pp] bi t xs
| (_ :: xs) := compact_decl xs

/--
Remove identity functions from a term. These are normally
automatically generated with terms like `show t, from p` or
`(p : t)` which translate to some variant on `@id t p` in
order to retain the type.
-/
meta def clean (q : parse texpr) : tactic unit :=
do tgt : expr ← target,
   e ← i_to_expr_strict ``(%%q : %%tgt),
   tactic.exact $ e.clean

meta def source_fields (missing : list name) (e : pexpr) : tactic (list (name × pexpr)) :=
do e ← to_expr e,
   t ← infer_type e,
   let struct_n : name := t.get_app_fn.const_name,
   fields ← expanded_field_list struct_n,
   let exp_fields := fields.filter (λ x, x.2 ∈ missing),
   exp_fields.mmap $ λ ⟨p,n⟩,
     (prod.mk n ∘ to_pexpr) <$> mk_mapp (n.update_prefix p) [none,some e]

meta def collect_struct' : pexpr → state_t (list $ expr×structure_instance_info) tactic pexpr | e :=
do some str ← pure (e.get_structure_instance_info)
       | e.traverse collect_struct',
   v ← monad_lift mk_mvar,
   modify (list.cons (v,str)),
   pure $ to_pexpr v

meta def collect_struct (e : pexpr) : tactic $ pexpr × list (expr×structure_instance_info) :=
prod.map id list.reverse <$> (collect_struct' e).run []

meta def refine_one (str : structure_instance_info) :
  tactic $ list (expr×structure_instance_info) :=
do    tgt ← target >>= whnf,
      let struct_n : name := tgt.get_app_fn.const_name,
      exp_fields ← expanded_field_list struct_n,
      let missing_f := exp_fields.filter (λ f, (f.2 : name) ∉ str.field_names),
      (src_field_names,src_field_vals) ← (@list.unzip name _ ∘ list.join) <$>
        str.sources.mmap (source_fields $ missing_f.map prod.snd),
      let provided  := exp_fields.filter (λ f, (f.2 : name) ∈ str.field_names),
      let missing_f' := missing_f.filter (λ x, x.2 ∉ src_field_names),
      vs ← mk_mvar_list missing_f'.length,
      (field_values,new_goals) ← list.unzip <$> (str.field_values.mmap collect_struct : tactic _),
      e' ← to_expr $ pexpr.mk_structure_instance
          { struct := some struct_n
          , field_names  := str.field_names  ++ missing_f'.map prod.snd ++ src_field_names
          , field_values := field_values ++ vs.map to_pexpr         ++ src_field_vals },
      tactic.exact e',
      gs ← with_enable_tags (
        mzip_with (λ (n : name × name) v, do
           set_goals [v],
           try (dsimp_target simp_lemmas.mk),
           apply_auto_param
             <|> apply_opt_param
             <|> (set_main_tag [`_field,n.2,n.1]),
           get_goals)
        missing_f' vs),
      set_goals gs.join,
      return new_goals.join

meta def refine_recursively : expr × structure_instance_info → tactic (list expr) | (e,str) :=
do set_goals [e],
   rs ← refine_one str,
   gs ← get_goals,
   gs' ← rs.mmap refine_recursively,
   return $ gs'.join ++ gs

/--
`refine_struct { .. }` acts like `refine` but works only with structure instance
literals. It creates a goal for each missing field and tags it with the name of the
field so that `have_field` can be used to generically refer to the field currently
being refined.

As an example, we can use `refine_struct` to automate the construction of semigroup
instances:

```lean
refine_struct ( { .. } : semigroup α ),
-- case semigroup, mul
-- α : Type u,
-- ⊢ α → α → α

-- case semigroup, mul_assoc
-- α : Type u,
-- ⊢ ∀ (a b c : α), a * b * c = a * (b * c)
```

`have_field`, used after `refine_struct _`, poses `field` as a local constant
with the type of the field of the current goal:

```lean
refine_struct ({ .. } : semigroup α),
{ have_field, ... },
{ have_field, ... },
```
behaves like
```lean
refine_struct ({ .. } : semigroup α),
{ have field := @semigroup.mul, ... },
{ have field := @semigroup.mul_assoc, ... },
```
-/
meta def refine_struct : parse texpr → tactic unit | e :=
do (x,xs) ← collect_struct e,
   refine x,
   gs ← get_goals,
   xs' ← xs.mmap refine_recursively,
   set_goals (xs'.join ++ gs)

/--
`guard_hyp' h : t` fails if the hypothesis `h` does not have type `t`.
We use this tactic for writing tests.
Fixes `guard_hyp` by instantiating meta variables
-/
meta def guard_hyp' (n : parse ident) (p : parse $ tk ":" *> texpr) : tactic unit :=
do h ← get_local n >>= infer_type >>= instantiate_mvars, guard_expr_eq h p

/--
`match_hyp h : t` fails if the hypothesis `h` does not match the type `t` (which may be a pattern).
We use this tactic for writing tests.
-/
meta def match_hyp (n : parse ident) (p : parse $ tk ":" *> texpr) (m := reducible) : tactic (list expr) :=
do
  h ← get_local n >>= infer_type >>= instantiate_mvars,
  match_expr p h m

/--
`guard_expr_strict t := e` fails if the expr `t` is not equal to `e`. By contrast
to `guard_expr`, this tests strict (syntactic) equality.
We use this tactic for writing tests.
-/
meta def guard_expr_strict (t : expr) (p : parse $ tk ":=" *> texpr) : tactic unit :=
do e ← to_expr p, guard (t = e)

/--
`guard_target_strict t` fails if the target of the main goal is not syntactically `t`.
We use this tactic for writing tests.
-/
meta def guard_target_strict (p : parse texpr) : tactic unit :=
do t ← target, guard_expr_strict t p

/--
`guard_hyp_strict h : t` fails if the hypothesis `h` does not have type syntactically equal
to `t`.
We use this tactic for writing tests.
-/
meta def guard_hyp_strict (n : parse ident) (p : parse $ tk ":" *> texpr) : tactic unit :=
do h ← get_local n >>= infer_type >>= instantiate_mvars, guard_expr_strict h p

/-- Tests that there are `n` hypotheses in the current context. -/
meta def guard_hyp_nums (n : ℕ) : tactic unit :=
do k ← local_context,
   guard (n = k.length) <|> fail format!"{k.length} hypotheses found"

/-- Test that `t` is the tag of the main goal. -/
meta def guard_tags (tags : parse ident*) : tactic unit :=
do (t : list name) ← get_main_tag,
   guard (t = tags)

/-- `guard_proof_term { t } e` applies tactic `t` and tests whether the resulting proof term
  unifies with `p`. -/
meta def guard_proof_term (t : itactic) (p : parse texpr) : itactic :=
do
  g :: _ ← get_goals,
  e ← to_expr p,
  t,
  g ← instantiate_mvars g,
  unify e g

/-- `success_if_fail_with_msg { tac } msg` succeeds if the interactive tactic `tac` fails with
error message `msg` (for test writing purposes). -/
meta def success_if_fail_with_msg (tac : tactic.interactive.itactic) :=
tactic.success_if_fail_with_msg tac

/-- Get the field of the current goal. -/
meta def get_current_field : tactic name :=
do [_,field,str] ← get_main_tag,
   expr.const_name <$> resolve_name (field.update_prefix str)

meta def field (n : parse ident) (tac : itactic) : tactic unit :=
do gs ← get_goals,
   ts ← gs.mmap get_tag,
   ([g],gs') ← pure $ (list.zip gs ts).partition (λ x, x.snd.nth 1 = some n),
   set_goals [g.1],
   tac, done,
   set_goals $ gs'.map prod.fst

/--
`have_field`, used after `refine_struct _` poses `field` as a local constant
with the type of the field of the current goal:

```lean
refine_struct ({ .. } : semigroup α),
{ have_field, ... },
{ have_field, ... },
```
behaves like
```lean
refine_struct ({ .. } : semigroup α),
{ have field := @semigroup.mul, ... },
{ have field := @semigroup.mul_assoc, ... },
```
-/
meta def have_field : tactic unit :=
propagate_tags $
get_current_field
>>= mk_const
>>= note `field none
>>  return ()

/-- `apply_field` functions as `have_field, apply field, clear field` -/
meta def apply_field : tactic unit :=
propagate_tags $
get_current_field >>= applyc

add_tactic_doc
{ name       := "refine_struct",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.refine_struct, `tactic.interactive.apply_field,
                 `tactic.interactive.have_field],
  tags       := ["structures"],
  inherit_description_from := `tactic.interactive.refine_struct }

/--
`apply_rules hs n` applies the list of lemmas `hs` and `assumption` on the
first goal and the resulting subgoals, iteratively, at most `n` times.
`n` is optional, equal to 50 by default.
You can pass an `apply_cfg` option argument as `apply_rules hs n opt`.
(A typical usage would be with `apply_rules hs n { md := reducible })`,
which asks `apply_rules` to not unfold `semireducible` definitions (i.e. most)
when checking if a lemma matches the goal.)

`hs` can contain user attributes: in this case all theorems with this
attribute are added to the list of rules.

For instance:

```lean
@[user_attribute]
meta def mono_rules : user_attribute :=
{ name := `mono_rules,
  descr := "lemmas usable to prove monotonicity" }

attribute [mono_rules] add_le_add mul_le_mul_of_nonneg_right

lemma my_test {a b c d e : real} (h1 : a ≤ b) (h2 : c ≤ d) (h3 : 0 ≤ e) :
a + c * e + a + c + 0 ≤ b + d * e + b + d + e :=
-- any of the following lines solve the goal:
add_le_add (add_le_add (add_le_add (add_le_add h1 (mul_le_mul_of_nonneg_right h2 h3)) h1 ) h2) h3
by apply_rules [add_le_add, mul_le_mul_of_nonneg_right]
by apply_rules [mono_rules]
by apply_rules mono_rules
```
-/
meta def apply_rules (hs : parse pexpr_list_or_texpr) (n : nat := 50) (opt : apply_cfg := {}) :
  tactic unit :=
tactic.apply_rules hs n opt

add_tactic_doc
{ name       := "apply_rules",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.apply_rules],
  tags       := ["lemma application"] }

meta def return_cast (f : option expr) (t : option (expr × expr))
  (es : list (expr × expr × expr))
  (e x x' eq_h : expr) :
  tactic (option (expr × expr) × list (expr × expr × expr)) :=
(do guard (¬ e.has_var),
    unify x x',
    u ← mk_meta_univ,
    f ← f <|> mk_mapp ``_root_.id [(expr.sort u : expr)],
    t' ← infer_type e,
    some (f',t) ← pure t | return (some (f,t'), (e,x',eq_h) :: es),
    infer_type e >>= is_def_eq t,
    unify f f',
    return (some (f,t), (e,x',eq_h) :: es)) <|>
return (t, es)

meta def list_cast_of_aux (x : expr) (t : option (expr × expr))
  (es : list (expr × expr × expr)) :
  expr → tactic (option (expr × expr) × list (expr × expr × expr))
| e@`(cast %%eq_h %%x') := return_cast none t es e x x' eq_h
| e@`(eq.mp %%eq_h %%x') := return_cast none t es e x x' eq_h
| e@`(eq.mpr %%eq_h %%x') := mk_eq_symm eq_h >>= return_cast none t es e x x'
| e@`(@eq.subst %%α %%p %%a %%b  %%eq_h %%x') := return_cast p t es e x x' eq_h
| e@`(@eq.substr %%α %%p %%a %%b %%eq_h %%x') := mk_eq_symm eq_h >>= return_cast p t es e x x'
| e@`(@eq.rec %%α %%a %%f %%x' _  %%eq_h) := return_cast f t es e x x' eq_h
| e@`(@eq.rec_on %%α %%a %%f %%b  %%eq_h %%x') := return_cast f t es e x x' eq_h
| e := return (t,es)

meta def list_cast_of (x tgt : expr) : tactic (list (expr × expr × expr)) :=
(list.reverse ∘ prod.snd) <$> tgt.mfold (none, []) (λ e i es, list_cast_of_aux x es.1 es.2 e)

private meta def h_generalize_arg_p_aux : pexpr → parser (pexpr × name)
| (app (app (macro _ [const `heq _ ]) h) (local_const x _ _ _)) := pure (h, x)
| _ := fail "parse error"

private meta def h_generalize_arg_p : parser (pexpr × name) :=
with_desc "expr == id" $ parser.pexpr 0 >>= h_generalize_arg_p_aux

/--
`h_generalize Hx : e == x` matches on `cast _ e` in the goal and replaces it with
`x`. It also adds `Hx : e == x` as an assumption. If `cast _ e` appears multiple
times (not necessarily with the same proof), they are all replaced by `x`. `cast`
`eq.mp`, `eq.mpr`, `eq.subst`, `eq.substr`, `eq.rec` and `eq.rec_on` are all treated
as casts.

- `h_generalize Hx : e == x with h` adds hypothesis `α = β` with `e : α, x : β`;
- `h_generalize Hx : e == x with _` chooses automatically chooses the name of
  assumption `α = β`;
- `h_generalize! Hx : e == x` reverts `Hx`;
- when `Hx` is omitted, assumption `Hx : e == x` is not added.
-/
meta def h_generalize (rev : parse (tk "!")?)
     (h : parse ident_?)
     (_ : parse (tk ":"))
     (arg : parse h_generalize_arg_p)
     (eqs_h : parse ( (tk "with" >> pure <$> ident_) <|> pure [])) :
  tactic unit :=
do let (e,n) := arg,
   let h' := if h = `_ then none else h,
   h' ← (h' : tactic name) <|> get_unused_name ("h" ++ n.to_string : string),
   e ← to_expr e,
   tgt ← target,
   ((e,x,eq_h)::es) ← list_cast_of e tgt | fail "no cast found",
   interactive.generalize h' () (to_pexpr e, n),
   asm ← get_local h',
   v ← get_local n,
   hs ← es.mmap (λ ⟨e,_⟩, mk_app `eq [e,v]),
   (eqs_h.zip [e]).mmap' (λ ⟨h,e⟩, do
        h ← if h ≠ `_ then pure h else get_unused_name `h,
        () <$ note h none eq_h ),
   hs.mmap' (λ h,
     do h' ← assert `h h,
        tactic.exact asm,
        try (rewrite_target h'),
        tactic.clear h' ),
   when h.is_some (do
     (to_expr ``(heq_of_eq_rec_left %%eq_h %%asm)
       <|> to_expr ``(heq_of_cast_eq %%eq_h %%asm))
     >>= note h' none >> pure ()),
   tactic.clear asm,
   when rev.is_some (interactive.revert [n])

add_tactic_doc
{ name       := "h_generalize",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.h_generalize],
  tags       := ["context management"] }

/-- Tests whether `t` is definitionally equal to `p`. The difference with `guard_expr_eq` is that
  this uses definitional equality instead of alpha-equivalence. -/
meta def guard_expr_eq' (t : expr) (p : parse $ tk ":=" *> texpr) : tactic unit :=
do e ← to_expr p, is_def_eq t e

/--
`guard_target' t` fails if the target of the main goal is not definitionally equal to `t`.
We use this tactic for writing tests.
The difference with `guard_target` is that this uses definitional equality instead of
alpha-equivalence.
-/
meta def guard_target' (p : parse texpr) : tactic unit :=
do t ← target, guard_expr_eq' t p

add_tactic_doc
{ name       := "guard_target'",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.guard_target'],
  tags       := ["testing"] }

/--
a weaker version of `trivial` that tries to solve the goal by reflexivity or by reducing it to true,
unfolding only `reducible` constants. -/
meta def triv : tactic unit :=
tactic.triv' <|> tactic.reflexivity reducible <|> tactic.contradiction <|> fail "triv tactic failed"

add_tactic_doc
{ name       := "triv",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.triv],
  tags       := ["finishing"] }

/--
Similar to `existsi`. `use x` will instantiate the first term of an `∃` or `Σ` goal with `x`.
It will then try to close the new goal using `triv`, or try to simplify it by applying `exists_prop`.
Unlike `existsi`, `x` is elaborated with respect to the expected type.
`use` will alternatively take a list of terms `[x0, ..., xn]`.

`use` will work with constructors of arbitrary inductive types.

Examples:
```lean
example (α : Type) : ∃ S : set α, S = S :=
by use ∅

example : ∃ x : ℤ, x = x :=
by use 42

example : ∃ n > 0, n = n :=
begin
  use 1,
  -- goal is now 1 > 0 ∧ 1 = 1, whereas it would be ∃ (H : 1 > 0), 1 = 1 after existsi 1.
  exact ⟨zero_lt_one, rfl⟩,
end

example : ∃ a b c : ℤ, a + b + c = 6 :=
by use [1, 2, 3]

example : ∃ p : ℤ × ℤ, p.1 = 1 :=
by use ⟨1, 42⟩

example : Σ x y : ℤ, (ℤ × ℤ) × ℤ :=
by use [1, 2, 3, 4, 5]

inductive foo
| mk : ℕ → bool × ℕ → ℕ → foo

example : foo :=
by use [100, tt, 4, 3]
```
-/
meta def use (l : parse pexpr_list_or_texpr) : tactic unit :=
focus1 $
  tactic.use l;
  try (triv <|> (do
        `(Exists %%p) ← target,
        to_expr ``(exists_prop.mpr) >>= tactic.apply >> skip))

add_tactic_doc
{ name       := "use",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.use, `tactic.interactive.existsi],
  tags       := ["logic"],
  inherit_description_from := `tactic.interactive.use }

/--
`clear_aux_decl` clears every `aux_decl` in the local context for the current goal.
This includes the induction hypothesis when using the equation compiler and
`_let_match` and `_fun_match`.

It is useful when using a tactic such as `finish`, `simp *` or `subst` that may use these
auxiliary declarations, and produce an error saying the recursion is not well founded.

```lean
example (n m : ℕ) (h₁ : n = m) (h₂ : ∃ a : ℕ, a = n ∧ a = m) : 2 * m = 2 * n :=
let ⟨a, ha⟩ := h₂ in
begin
  clear_aux_decl, -- subst will fail without this line
  subst h₁
end

example (x y : ℕ) (h₁ : ∃ n : ℕ, n * 1 = 2) (h₂ : 1 + 1 = 2 → x * 1 = y) : x = y :=
let ⟨n, hn⟩ := h₁ in
begin
  clear_aux_decl, -- finish produces an error without this line
  finish
end
```
-/
meta def clear_aux_decl : tactic unit := tactic.clear_aux_decl

add_tactic_doc
{ name       := "clear_aux_decl",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.clear_aux_decl, `tactic.clear_aux_decl],
  tags       := ["context management"],
  inherit_description_from := `tactic.interactive.clear_aux_decl }

meta def loc.get_local_pp_names : loc → tactic (list name)
| loc.wildcard := list.map expr.local_pp_name <$> local_context
| (loc.ns l) := return l.reduce_option

meta def loc.get_local_uniq_names (l : loc) : tactic (list name) :=
list.map expr.local_uniq_name <$> l.get_locals

/--
The logic of `change x with y at l` fails when there are dependencies.
`change'` mimics the behavior of `change`, except in the case of `change x with y at l`.
In this case, it will correctly replace occurences of `x` with `y` at all possible hypotheses
in `l`. As long as `x` and `y` are defeq, it should never fail.
-/
meta def change' (q : parse texpr) : parse (tk "with" *> texpr)? → parse location → tactic unit
| none (loc.ns [none]) := do e ← i_to_expr q, change_core e none
| none (loc.ns [some h]) := do eq ← i_to_expr q, eh ← get_local h, change_core eq (some eh)
| none _ := fail "change-at does not support multiple locations"
| (some w) l :=
  do l' ← loc.get_local_pp_names l,
     l'.mmap' (λ e, try (change_with_at q w e)),
     when l.include_goal $ change q w (loc.ns [none])

add_tactic_doc
{ name       := "change'",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.change', `tactic.interactive.change],
  tags       := ["renaming"],
  inherit_description_from := `tactic.interactive.change' }

private meta def opt_dir_with : parser (option (bool × name)) :=
(do tk "with",
   arrow ← (tk "<-")?,
   h ← ident,
   return (arrow.is_some, h)) <|> return none

/--
`set a := t with h` is a variant of `let a := t`. It adds the hypothesis `h : a = t` to
the local context and replaces `t` with `a` everywhere it can.

`set a := t with ←h` will add `h : t = a` instead.

`set! a := t with h` does not do any replacing.

```lean
example (x : ℕ) (h : x = 3)  : x + x + x = 9 :=
begin
  set y := x with ←h_xy,
/-
x : ℕ,
y : ℕ := x,
h_xy : x = y,
h : y = 3
⊢ y + y + y = 9
-/
end
```
-/
meta def set (h_simp : parse (tk "!")?) (a : parse ident) (tp : parse ((tk ":") >> texpr)?)
  (_ : parse (tk ":=")) (pv : parse texpr)
  (rev_name : parse opt_dir_with) :=
do tp ← i_to_expr $ tp.get_or_else pexpr.mk_placeholder,
   pv ← to_expr ``(%%pv : %%tp),
   tp ← instantiate_mvars tp,
   definev a tp pv,
   when h_simp.is_none $ change' ``(%%pv) (some (expr.const a [])) $ interactive.loc.wildcard,
   match rev_name with
   | some (flip, id) :=
     do nv ← get_local a,
        mk_app `eq (cond flip [pv, nv] [nv, pv]) >>= assert id,
        reflexivity
   | none := skip
   end

add_tactic_doc
{ name       := "set",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.set],
  tags       := ["context management"] }

/--
`clear_except h₀ h₁` deletes all the assumptions it can except for `h₀` and `h₁`.
-/
meta def clear_except (xs : parse ident *) : tactic unit :=
do n ← xs.mmap (try_core ∘ get_local) >>= revert_lst ∘ list.filter_map id,
   ls ← local_context,
   ls.reverse.mmap' $ try ∘ tactic.clear,
   intron_no_renames n

add_tactic_doc
{ name       := "clear_except",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.clear_except],
  tags       := ["context management"] }

meta def format_names (ns : list name) : format :=
format.join $ list.intersperse " " (ns.map to_fmt)

private meta def indent_bindents (l r : string) : option (list name) → expr → tactic format
| none e :=
  do e ← pp e,
     pformat!"{l}{format.nest l.length e}{r}"
| (some ns) e :=
  do e ← pp e,
     let ns := format_names ns,
     let margin := l.length + ns.to_string.length + " : ".length,
     pformat!"{l}{ns} : {format.nest margin e}{r}"

private meta def format_binders : list name × binder_info × expr → tactic format
| (ns, binder_info.default, t) := indent_bindents "(" ")" ns t
| (ns, binder_info.implicit, t) := indent_bindents "{" "}" ns t
| (ns, binder_info.strict_implicit, t) := indent_bindents "⦃" "⦄" ns t
| ([n], binder_info.inst_implicit, t) :=
  if "_".is_prefix_of n.to_string
    then indent_bindents "[" "]" none t
    else indent_bindents "[" "]" [n] t
| (ns, binder_info.inst_implicit, t) := indent_bindents "[" "]" ns t
| (ns, binder_info.aux_decl, t) := indent_bindents "(" ")" ns t

private meta def partition_vars' (s : name_set) : list expr → list expr → list expr → tactic (list expr × list expr)
| [] as bs := pure (as.reverse, bs.reverse)
| (x :: xs) as bs :=
do t ← infer_type x,
   if t.has_local_in s then partition_vars' xs as (x :: bs)
     else partition_vars' xs (x :: as) bs

private meta def partition_vars : tactic (list expr × list expr) :=
do ls ← local_context,
   partition_vars' (name_set.of_list $ ls.map expr.local_uniq_name) ls [] []

/--
Format the current goal as a stand-alone example. Useful for testing tactics
or creating [minimal working examples](https://leanprover-community.github.io/mwe.html).

* `extract_goal`: formats the statement as an `example` declaration
* `extract_goal my_decl`: formats the statement as a `lemma` or `def` declaration
  called `my_decl`
* `extract_goal with i j k:` only use local constants `i`, `j`, `k` in the declaration

Examples:

```lean
example (i j k : ℕ) (h₀ : i ≤ j) (h₁ : j ≤ k) : i ≤ k :=
begin
  extract_goal,
     -- prints:
     -- example (i j k : ℕ) (h₀ : i ≤ j) (h₁ : j ≤ k) : i ≤ k :=
     -- begin
     --   admit,
     -- end
  extract_goal my_lemma
     -- prints:
     -- lemma my_lemma (i j k : ℕ) (h₀ : i ≤ j) (h₁ : j ≤ k) : i ≤ k :=
     -- begin
     --   admit,
     -- end
end

example {i j k x y z w p q r m n : ℕ} (h₀ : i ≤ j) (h₁ : j ≤ k) (h₁ : k ≤ p) (h₁ : p ≤ q) : i ≤ k :=
begin
  extract_goal my_lemma,
    -- prints:
    -- lemma my_lemma {i j k x y z w p q r m n : ℕ}
    --   (h₀ : i ≤ j)
    --   (h₁ : j ≤ k)
    --   (h₁ : k ≤ p)
    --   (h₁ : p ≤ q) :
    --   i ≤ k :=
    -- begin
    --   admit,
    -- end

  extract_goal my_lemma with i j k
    -- prints:
    -- lemma my_lemma {p i j k : ℕ}
    --   (h₀ : i ≤ j)
    --   (h₁ : j ≤ k)
    --   (h₁ : k ≤ p) :
    --   i ≤ k :=
    -- begin
    --   admit,
    -- end
end

example : true :=
begin
  let n := 0,
  have m : ℕ, admit,
  have k : fin n, admit,
  have : n + m + k.1 = 0, extract_goal,
    -- prints:
    -- example (m : ℕ)  : let n : ℕ := 0 in ∀ (k : fin n), n + m + k.val = 0 :=
    -- begin
    --   intros n k,
    --   admit,
    -- end
end
```

-/
meta def extract_goal (print_use : parse $ tt <$ tk "!" <|> pure ff)
  (n : parse ident?) (vs : parse with_ident_list)
  : tactic unit :=
do tgt ← target,
   solve_aux tgt $ do {
     ((cxt₀,cxt₁,ls,tgt),_) ← solve_aux tgt $ do {
         when (¬ vs.empty) (clear_except vs),
         ls ← local_context,
         ls ← ls.mfilter $ succeeds ∘ is_local_def,
         n ← revert_lst ls,
         (c₀,c₁) ← partition_vars,
         tgt ← target,
         ls ← intron' n,
         pure (c₀,c₁,ls,tgt) },
     is_prop ← is_prop tgt,
     let title := match n, is_prop with
                  | none, _ := to_fmt "example"
                  | (some n), tt := format!"lemma {n}"
                  | (some n), ff := format!"def {n}"
                  end,
     cxt₀ ← compact_decl cxt₀ >>= list.mmap format_binders,
     cxt₁ ← compact_decl cxt₁ >>= list.mmap format_binders,
     stmt ← pformat!"{tgt} :=",
     let fmt :=
       format.group $ format.nest 2 $
         title ++ cxt₀.foldl (λ acc x, acc ++ format.group (format.line ++ x)) "" ++
         format.join (list.map (λ x, format.line ++ x) cxt₁) ++ " :" ++
         format.line ++ stmt,
     trace $ fmt.to_string $ options.mk.set_nat `pp.width 80,
     let var_names := format.intercalate " " $ ls.map (to_fmt ∘ local_pp_name),
     let call_intron := if ls.empty
                     then to_fmt ""
                     else format!"\n  intros {var_names},",
     trace!"begin{call_intron}\n  admit,\nend\n" },
   skip

add_tactic_doc
{ name       := "extract_goal",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.extract_goal],
  tags       := ["goal management", "proof extraction", "debugging"] }

/--
`inhabit α` tries to derive a `nonempty α` instance and then upgrades this
to an `inhabited α` instance.
If the target is a `Prop`, this is done constructively;
otherwise, it uses `classical.choice`.

```lean
example (α) [nonempty α] : ∃ a : α, true :=
begin
  inhabit α,
  existsi default α,
  trivial
end
```
-/
meta def inhabit (t : parse parser.pexpr) (inst_name : parse ident?) : tactic unit :=
do ty ← i_to_expr t,
   nm ← returnopt inst_name <|> get_unused_name `inst,
   tgt ← target,
   tgt_is_prop ← is_prop tgt,
   if tgt_is_prop then do
     decorate_error "could not infer nonempty instance:" $
       mk_mapp ``nonempty.elim_to_inhabited [ty, none, tgt] >>= tactic.apply,
     introI nm
   else do
     decorate_error "could not infer nonempty instance:" $
      mk_mapp ``classical.inhabited_of_nonempty' [ty, none] >>= note nm none,
     resetI

add_tactic_doc
{ name       := "inhabit",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.inhabit],
  tags       := ["context management", "type class"] }

/-- `revert_deps n₁ n₂ ...` reverts all the hypotheses that depend on one of `n₁, n₂, ...`
It does not revert `n₁, n₂, ...` themselves (unless they depend on another `nᵢ`). -/
meta def revert_deps (ns : parse ident*) : tactic unit :=
propagate_tags $
  ns.mmap get_local >>= revert_reverse_dependencies_of_hyps >> skip

add_tactic_doc
{ name       := "revert_deps",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.revert_deps],
  tags       := ["context management", "goal management"] }

/-- `revert_after n` reverts all the hypotheses after `n`. -/
meta def revert_after (n : parse ident) : tactic unit :=
propagate_tags $ get_local n >>= tactic.revert_after >> skip

add_tactic_doc
{ name       := "revert_after",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.revert_after],
  tags       := ["context management", "goal management"] }

/-- Reverts all local constants on which the target depends (recursively). -/
meta def revert_target_deps : tactic unit :=
propagate_tags $ tactic.revert_target_deps >> skip

add_tactic_doc
{ name       := "revert_target_deps",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.revert_target_deps],
  tags       := ["context management", "goal management"] }

/-- `clear_value n₁ n₂ ...` clears the bodies of the local definitions `n₁, n₂ ...`, changing them
into regular hypotheses. A hypothesis `n : α := t` is changed to `n : α`. -/
meta def clear_value (ns : parse ident*) : tactic unit :=
propagate_tags $ ns.reverse.mmap get_local >>= tactic.clear_value

add_tactic_doc
{ name       := "clear_value",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.clear_value],
  tags       := ["context management"] }

/--
`generalize' : e = x` replaces all occurrences of `e` in the target with a new hypothesis `x` of
the same type.

`generalize' h : e = x` in addition registers the hypothesis `h : e = x`.

`generalize'` is similar to `generalize`. The difference is that `generalize' : e = x` also
succeeds when `e` does not occur in the goal. It is similar to `set`, but the resulting hypothesis
`x` is not a local definition.
-/
meta def generalize' (h : parse ident?) (_ : parse $ tk ":") (p : parse generalize_arg_p) : tactic unit :=
propagate_tags $
do let (p, x) := p,
   e ← i_to_expr p,
   some h ← pure h | tactic.generalize' e x >> skip,
   -- `h` is given, the regular implementation of `generalize` works.
   tgt ← target,
   tgt' ← do {
     ⟨tgt', _⟩ ← solve_aux tgt (tactic.generalize e x >> target),
     to_expr ``(Π x, %%e = x → %%(tgt'.binding_body.lift_vars 0 1))
   } <|> to_expr ``(Π x, %%e = x → %%tgt),
   t ← assert h tgt',
   swap,
   exact ``(%%t %%e rfl),
   intro x,
   intro h

add_tactic_doc
{ name       := "generalize'",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.generalize'],
  tags       := ["context management"] }

end interactive
end tactic


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner
-/
import data.buffer data.dlist

inductive parse_result (α : Type)
| done (pos : ℕ) (result : α) : parse_result
| fail (pos : ℕ) (expected : dlist string) : parse_result

/-- The parser monad. If you are familiar with the Parsec library in Haskell, you will understand this.  -/
def parser (α : Type) :=
∀ (input : char_buffer) (start : ℕ), parse_result α

namespace parser
variables {α β γ : Type}

protected def bind (p : parser α) (f : α → parser β) : parser β :=
λ input pos, match p input pos with
| parse_result.done pos a           := f a input pos
| parse_result.fail pos expected := parse_result.fail pos expected
end

protected def pure (a : α) : parser α :=
λ input pos, parse_result.done pos a

private lemma parser.id_map (p : parser α) : parser.bind p parser.pure = p :=
begin
apply funext, intro input,
apply funext, intro pos,
dunfold parser.bind,
cases (p input pos); exact rfl
end

private lemma parser.bind_assoc (p : parser α) (q : α → parser β) (r : β → parser γ) :
  parser.bind (parser.bind p q) r = parser.bind p (λ a, parser.bind (q a) r) :=
begin
apply funext, intro input,
apply funext, intro pos,
dunfold parser.bind,
cases (p input pos); try {dunfold bind},
cases (q result input pos_1); try {dunfold bind},
all_goals {refl}
end

protected def fail (msg : string) : parser α :=
λ _ pos, parse_result.fail pos (dlist.singleton msg)

instance : monad parser :=
{ pure := @parser.pure, bind := @parser.bind }

instance : is_lawful_monad parser :=
{ id_map := @parser.id_map,
  pure_bind := λ _ _ _ _, rfl,
  bind_assoc := @parser.bind_assoc }

instance : monad_fail parser :=
{ fail := @parser.fail, ..parser.monad }

protected def failure : parser α :=
λ _ pos, parse_result.fail pos dlist.empty

protected def orelse (p q : parser α) : parser α :=
λ input pos, match p input pos with
| parse_result.fail pos₁ expected₁ :=
  if pos₁ ≠ pos then parse_result.fail pos₁ expected₁ else
  match q input pos with
  | parse_result.fail pos₂ expected₂ :=
    if pos₁ < pos₂ then
      parse_result.fail pos₁ expected₁
    else if pos₂ < pos₁ then
      parse_result.fail pos₂ expected₂
    else -- pos₁ = pos₂
      parse_result.fail pos₁ (expected₁ ++ expected₂)
  | ok := ok
  end
  | ok := ok
end

instance : alternative parser :=
{ failure := @parser.failure,
  orelse := @parser.orelse }

instance : inhabited (parser α) :=
⟨parser.failure⟩

/-- Overrides the expected token name, and does not consume input on failure. -/
def decorate_errors (msgs : thunk (list string)) (p : parser α) : parser α :=
λ input pos, match p input pos with
| parse_result.fail _ expected :=
  parse_result.fail pos (dlist.lazy_of_list (msgs ()))
| ok := ok
end

/-- Overrides the expected token name, and does not consume input on failure. -/
def decorate_error (msg : thunk string) (p : parser α) : parser α :=
decorate_errors [msg ()] p

/-- Matches a single character. Fails only if there is no more input. -/
def any_char : parser char :=
λ input pos,
if h : pos < input.size
  then
    let c := input.read ⟨pos, h⟩ in
    parse_result.done (pos+1) c
  else
    parse_result.fail pos dlist.empty

/-- Matches a single character satisfying the given predicate. -/
def sat (p : char → Prop) [decidable_pred p] : parser char :=
λ input pos,
if h : pos < input.size
  then
    let c := input.read ⟨pos, h⟩ in
    if p c then
      parse_result.done (pos+1) c
    else
      parse_result.fail pos dlist.empty
  else
    parse_result.fail pos dlist.empty

/-- Matches the empty word. -/
def eps : parser unit := return ()

/-- Matches the given character. -/
def ch (c : char) : parser unit :=
decorate_error c.to_string $ sat (= c) >> eps

/-- Matches a whole char_buffer.  Does not consume input in case of failure. -/
def char_buf (s : char_buffer) : parser unit :=
decorate_error s.to_string $ s.to_list.mmap' ch

/-- Matches one out of a list of characters. -/
def one_of (cs : list char) : parser char :=
decorate_errors (do c ← cs, return c.to_string) $
sat (∈ cs)

def one_of' (cs : list char) : parser unit :=
one_of cs >> eps

/-- Matches a string.  Does not consume input in case of failure. -/
def str (s : string) : parser unit :=
decorate_error s $ s.to_list.mmap' ch

/-- Number of remaining input characters. -/
def remaining : parser ℕ :=
λ input pos, parse_result.done pos (input.size - pos)

/-- Matches the end of the input. -/
def eof : parser unit :=
decorate_error "<end-of-file>" $
do rem ← remaining, guard $ rem = 0

def foldr_core (f : α → β → β) (p : parser α) (b : β) : ∀ (reps : ℕ), parser β
| 0 := failure
| (reps+1) := (do x ← p, xs ← foldr_core reps, return (f x xs)) <|> return b

/-- Matches zero or more occurrences of `p`, and folds the result. -/
def foldr (f : α → β → β) (p : parser α) (b : β) : parser β :=
λ input pos, foldr_core f p b (input.size - pos + 1) input pos

def foldl_core (f : α → β → α) : ∀ (a : α) (p : parser β) (reps : ℕ), parser α
| a p 0 := failure
| a p (reps+1) := (do x ← p, foldl_core (f a x) p reps) <|> return a

/-- Matches zero or more occurrences of `p`, and folds the result. -/
def foldl (f : α → β → α) (a : α) (p : parser β) : parser α :=
λ input pos, foldl_core f a p (input.size - pos + 1) input pos

/-- Matches zero or more occurrences of `p`. -/
def many (p : parser α) : parser (list α) :=
foldr list.cons p []

def many_char (p : parser char) : parser string :=
list.as_string <$> many p

/-- Matches zero or more occurrences of `p`. -/
def many' (p : parser α) : parser unit :=
many p >> eps

/-- Matches one or more occurrences of `p`. -/
def many1 (p : parser α) : parser (list α) :=
list.cons <$> p <*> many p

/-- Matches one or more occurences of the char parser `p` and implodes them into a string. -/
def many_char1 (p : parser char) : parser string :=
list.as_string <$> many1 p

/-- Matches one or more occurrences of `p`, separated by `sep`. -/
def sep_by1 (sep : parser unit) (p : parser α) : parser (list α) :=
list.cons <$> p <*> many (sep >> p)

/-- Matches zero or more occurrences of `p`, separated by `sep`. -/
def sep_by (sep : parser unit) (p : parser α) : parser (list α) :=
sep_by1 sep p <|> return []

def fix_core (F : parser α → parser α) : ∀ (max_depth : ℕ), parser α
| 0             := failure
| (max_depth+1) := F (fix_core max_depth)

/-- Matches a digit (0-9). -/
def digit : parser nat := decorate_error "<digit>" $ do
  c ← sat (λ c, '0' ≤ c ∧ c ≤ '9'),
  pure $ c.to_nat - '0'.to_nat

/-- Matches a natural number. Large numbers may cause performance issues, so
don't run this parser on untrusted input. -/
def nat : parser nat := decorate_error "<natural>" $ do
  digits ← many1 digit,
  pure $ prod.fst $ digits.foldr
    (λ digit ⟨sum, magnitude⟩, ⟨sum + digit * magnitude, magnitude * 10⟩)
    ⟨0, 1⟩

/-- Fixpoint combinator satisfying `fix F = F (fix F)`. -/
def fix (F : parser α → parser α) : parser α :=
λ input pos, fix_core F (input.size - pos + 1) input pos

private def make_monospaced : char → char
| '\n' := ' '
| '\t' := ' '
| '\x0d' := ' '
| c := c

def mk_error_msg (input : char_buffer) (pos : ℕ) (expected : dlist string) : char_buffer :=
let left_ctx := (input.take pos).take_right 10,
    right_ctx := (input.drop pos).take 10 in
left_ctx.map make_monospaced ++ right_ctx.map make_monospaced ++ "\n".to_char_buffer ++
left_ctx.map (λ _, ' ') ++ "^\n".to_char_buffer ++
"\n".to_char_buffer ++
"expected: ".to_char_buffer
  ++ string.to_char_buffer (" | ".intercalate expected.to_list)
  ++ "\n".to_char_buffer

/-- Runs a parser on the given input.  The parser needs to match the complete input. -/
def run (p : parser α) (input : char_buffer) : sum string α :=
match (p <* eof) input 0 with
| parse_result.done pos res := sum.inr res
| parse_result.fail pos expected :=
  sum.inl $ buffer.to_string $ mk_error_msg input pos expected
end

/-- Runs a parser on the given input.  The parser needs to match the complete input. -/
def run_string (p : parser α) (input : string) : sum string α :=
run p input.to_char_buffer

end parser


import category_theory.shift
import for_mathlib.category_theory.quotient_misc
import for_mathlib.category_theory.functor.shift

import for_mathlib.category_theory.functor.shift_compatibility

noncomputable theory

namespace category_theory

open category

variables {C A : Type*} [category C] (r : hom_rel C)

lemma quotient.functor_map_eq {X Y : C} (f : X ⟶ Y) :
  (quotient.functor r).map f = quot.mk _ f := rfl

variables [add_monoid A] [has_shift C A]
  (h : ∀ (a : A) ⦃X Y : C⦄ (f₁ f₂ : X ⟶ Y), r f₁ f₂ → r (f₁⟦a⟧') (f₂⟦a⟧'))

variable {r}

namespace quotient

@[protected]
def shift_functor (a : A) : quotient r ⥤ quotient r :=
lift r (shift_functor C a ⋙ functor r) (λ X Y f₁ f₂ rel, quotient.sound r (h a f₁ f₂ rel))

def comm_shift (a : A) :
  shift_functor C a ⋙ functor r ≅ functor r ⋙ quotient.shift_functor h a :=
(quotient.lift.is_lift _ _ _).symm

@[simp]
lemma comm_shift_hom_app (a : A) (X : C) :
  (comm_shift h a).hom.app X = 𝟙 _ := rfl

@[simp]
lemma comm_shift_inv_app (a : A) (X : C) :
  (comm_shift h a).inv.app X = 𝟙 _ := rfl

def shift_ε : 𝟭 _ ≅ quotient.shift_functor h 0 :=
quotient.lift_nat_iso _ _ (functor.right_unitor _ ≪≫ (functor.left_unitor _).symm ≪≫
      iso_whisker_right (shift_functor_zero C A).symm _ ≪≫ comm_shift h 0)

@[simp]
lemma shift_ε_hom_app (X : C) :
  (shift_ε h).hom.app ((functor r).obj X) =
    (functor r).map ((shift_functor_zero C A).inv.app X) :=
begin
  dsimp [shift_ε],
  simp only [id_comp, comp_id],
end

def shift_μ (a b : A) :
  quotient.shift_functor h a ⋙ quotient.shift_functor h b ≅
  quotient.shift_functor h (a + b) :=
quotient.lift_nat_iso _ _ ((functor.associator _ _ _).symm ≪≫
  iso_whisker_right (comm_shift h a).symm _ ≪≫ functor.associator _ _ _ ≪≫
  iso_whisker_left _ (comm_shift h b).symm ≪≫ (functor.associator _ _ _).symm ≪≫
  iso_whisker_right (shift_functor_add C a b).symm _ ≪≫ comm_shift h (a + b))

@[simp]
lemma shift_μ_hom_app (a b : A) (X : C) :
  (shift_μ h a b).hom.app ((functor r).obj X) =
    (functor r).map ((shift_functor_add C a b).inv.app X) :=
begin
  dsimp [shift_μ],
  simpa only [functor.map_id, comp_id, id_comp],
end

local attribute [instance, reducible] endofunctor_monoidal_category
local attribute [reducible] discrete.add_monoidal

lemma associativity_compatibility (a b c : A) (X : C) :
  (shift_functor C c).map ((shift_functor_add C a b).inv.app X) ≫
    (shift_functor_add C (a + b) c).inv.app X =
  (shift_functor_add C b c).inv.app ((shift_functor C a).obj X) ≫
  (shift_functor_add C a (b + c)).inv.app X ≫ eq_to_hom (by rw add_assoc):=
begin
  dsimp,
  have eq := (congr_arg iso.hom (monoidal_functor.associativity_iso_eq
    (shift_monoidal_functor C A) (discrete.mk a) (discrete.mk b) (discrete.mk c))),
  replace eq := congr_app eq X,
  dsimp at eq,
  simp only [id_comp, functor.map_id, comp_id] at eq,
  erw ← reassoc_of eq, clear eq,
  simp only [eq_to_hom_map, eq_to_hom_app, eq_to_hom_trans, eq_to_hom_refl, comp_id],
end

lemma shift_associativity (a b c : A) :
  (shift_μ h a b).hom ◫ 𝟙 (quotient.shift_functor h c) ≫
    (shift_μ h (a + b) c).hom ≫ eq_to_hom (by rw add_assoc) =
  (functor.associator _ _ _).hom ≫ 𝟙 (quotient.shift_functor h a) ◫ (shift_μ h b c).hom ≫
    (shift_μ h a (b + c)).hom :=
quotient.nat_trans_ext _ _ (λ X, begin
  dsimp only [functor.associator, nat_trans.comp_app, nat_trans.hcomp_app,
    nat_trans.id_app, quotient.shift_functor],
  erw [id_comp, id_comp, shift_μ_hom_app, shift_μ_hom_app, shift_μ_hom_app,
    shift_μ_hom_app, assoc, functor.map_id, id_comp, lift_map_functor_map],
  dsimp only ,
  simp only [functor.comp_map, ← functor.map_comp, ← functor.map_comp_assoc,
    associativity_compatibility],
  simpa only [assoc, functor.map_comp, eq_to_hom_app, eq_to_hom_map, eq_to_hom_trans,
    eq_to_hom_refl, comp_id],
end)

lemma shift_left_unitality (a : A) :
  (shift_ε h).hom ◫ 𝟙 (quotient.shift_functor h a) ≫ (shift_μ h 0 a).hom =
    eq_to_hom (congr_arg (quotient.shift_functor h) (zero_add a).symm) :=
quotient.nat_trans_ext _ _ (λ X, begin
  dsimp [shift_ε, shift_μ, comm_shift],
  simp only [comp_id, id_comp, eq_to_hom_app],
  erw [functor.map_id, id_comp, id_comp],
  dsimp [quotient.shift_functor, lift_map],
  erw [← functor_map_eq, ← functor_map_eq, ← functor.map_comp],
  transitivity (functor r).map (eq_to_hom _), swap,
  { rw zero_add, },
  { congr' 1,
    simp only [obj_ε_app, eq_to_iso.inv, assoc, μ_inv_hom_app],
    erw [comp_id, eq_to_hom_map, eq_to_hom_app], },
  { apply eq_to_hom_map, },
end)

lemma shift_right_unitality (a : A) :
  𝟙 (quotient.shift_functor h a) ◫ (shift_ε h).hom ≫ (shift_μ h a 0).hom =
    eq_to_hom (congr_arg (quotient.shift_functor h) (add_zero a).symm) :=
quotient.nat_trans_ext _ _ (λ X, begin
  dsimp only [shift_ε, shift_μ, iso.trans, nat_trans.hcomp, nat_trans.comp_app,
    quotient.shift_functor, comm_shift, lift.is_lift],
  simp only [iso.symm_inv, assoc, iso.symm_hom, iso_whisker_right_hom, lift_nat_iso_hom,
    nat_trans.id_app, lift_nat_trans_app, nat_trans.comp_app, whisker_right_app, functor.map_id,
    nat_iso.of_components_hom_app, iso.refl_hom, nat_iso.of_components_inv_app, iso.refl_inv],
  dsimp,
  simp only [id_comp, comp_id, eq_to_hom_app],
  erw [← functor_map_eq, ← functor_map_eq, ← functor.map_comp],
  transitivity (functor r).map (eq_to_hom _), swap,
  { rw add_zero, },
  { congr' 1,
    simp only [ε_app_obj, eq_to_iso.inv, assoc, μ_inv_hom_app, comp_id,
      eq_to_hom_map, eq_to_hom_app], },
  { apply eq_to_hom_map, },
end)

@[protected]
def shift : has_shift (quotient r) A :=
has_shift_mk _ _
{ F := quotient.shift_functor h,
  ε := shift_ε h,
  μ := shift_μ h,
  associativity := λ a b c X, by simpa using congr_app (shift_associativity h a b c) X,
  left_unitality := λ a X, by simpa using congr_app (shift_left_unitality h a) X,
  right_unitality := λ a X, by simpa using congr_app (shift_right_unitality h a) X, }

def functor_comm_shift :
  @functor.has_comm_shift _ _ _ _ (functor r) A _ _
    (quotient.shift h) :=
{ iso := quotient.comm_shift h,
  iso_add := λ a b, begin
    ext K,
    dsimp,
    simp only [functor.comm_shift.add_hom_app, comm_shift_hom_app, id_comp],
    erw [functor.map_id, id_comp, id_comp],
    change _ ≫ (shift_μ h a b).hom.app ((functor r).obj K) = _,
    erw [shift_μ_hom_app, ← functor.map_comp, iso.inv_hom_id_app, functor.map_id],
  end,
  iso_zero := begin
    ext K,
    simp only [nat_trans.comp_app, lift.is_lift_hom, nat_trans.id_app],
    dsimp only [functor.comm_shift.unit, shift.compatibility.comm_shift.unit,
      iso.trans, iso.symm, nat_trans.comp_app, iso_whisker_right, whiskering_right,
      functor.map_iso, whisker_right, iso_whisker_left, functor.left_unitor,
      functor.right_unitor, whiskering_left, whisker_left],
    erw [id_comp, id_comp, id_comp, shift_ε_hom_app, ← functor.map_comp,
      iso.inv_hom_id_app, functor.map_id],
    refl,
  end, }

section

variables
  {D : Type*} [category D]
  {F : C ⥤ D} {F' : quotient r ⥤ D} (e : functor r ⋙ F' ≅ F)
  {B : Type*} [add_monoid B] [has_shift C B] [has_shift D B]
  [has_shift (quotient r) B] [(functor r).has_comm_shift B]
  [F.has_comm_shift B]

def comm_shift_iso_of_fac (a : B) :
  shift_functor (quotient r) a ⋙ F' ≅ F' ⋙ shift_functor D a :=
lift_nat_iso _ _ ((functor.associator _ _ _).symm ≪≫
    iso_whisker_right ((functor r).comm_shift_iso a).symm F' ≪≫
    functor.associator _ _ _ ≪≫ iso_whisker_left _ e ≪≫
    F.comm_shift_iso a ≪≫ iso_whisker_right e.symm _ ≪≫ functor.associator _ _ _)

@[simp]
lemma comm_shift_iso_of_fac_hom_app (a : B) (X : C) :
  (comm_shift_iso_of_fac e a).hom.app ((functor r).obj X) =
    F'.map (((functor r).comm_shift_iso a).inv.app X) ≫
    e.hom.app ((shift_functor C a).obj X) ≫
    (F.comm_shift_iso a).hom.app X ≫
    (shift_functor D a).map (e.inv.app X) :=
begin
  dsimp only [comm_shift_iso_of_fac],
  simp only [lift_nat_iso_hom, iso.trans_hom, iso.symm_hom, iso_whisker_right_hom,
    iso_whisker_left_hom, lift_nat_trans_app, nat_trans.comp_app,
    functor.associator_inv_app, whisker_right_app, functor.associator_hom_app,
    whisker_left_app, comp_id, id_comp],
end

@[simp]
lemma comm_shift_iso_of_fac_inv_app (a : B) (X : C) :
  (comm_shift_iso_of_fac e a).inv.app ((functor r).obj X) =
    (shift_functor D a).map (e.hom.app X) ≫
    (F.comm_shift_iso a).inv.app X ≫
    e.inv.app ((shift_functor C a).obj X) ≫
    F'.map (((functor r).comm_shift_iso a).hom.app X) :=
begin
  dsimp only [comm_shift_iso_of_fac],
  simp only [lift_nat_iso_inv, iso.trans_inv, iso_whisker_right_inv, iso.symm_inv, assoc,
    iso_whisker_left_inv, lift_nat_trans_app, nat_trans.comp_app,
    functor.associator_inv_app, whisker_right_app, whisker_left_app,
    functor.associator_hom_app, comp_id, id_comp],
end

variable (B)

def has_comm_shift : F'.has_comm_shift B :=
{ iso := λ a, comm_shift_iso_of_fac e a,
  iso_zero := begin
    ext1,
    refine nat_trans_ext _ _ (λ X, _),
    simp only [comm_shift_iso_of_fac_hom_app, functor.comm_shift.unit_hom_app,
      functor.comm_shift_iso_zero, functor.comm_shift.unit_inv_app,
      F'.map_comp, assoc, ← e.hom.naturality_assoc, functor.comp_map],
    nth_rewrite 1 ← functor.map_comp_assoc,
    erw [← functor.map_comp, iso.inv_hom_id_app, (functor r).map_id, F'.map_id, id_comp,
      ← nat_trans.naturality],
    dsimp only [functor.id],
    rw e.hom_inv_id_app_assoc,
  end,
  iso_add := λ a b, begin
    ext1,
    refine nat_trans_ext _ _ (λ X, _),
    simp only [functor.comm_shift.add_hom_app, assoc, functor.comm_shift_iso_add,
      comm_shift_iso_of_fac_hom_app, functor.map_comp, functor.comm_shift.add_inv_app],
    erw [← nat_trans.naturality_assoc, ← nat_trans.naturality_assoc,
      comm_shift_iso_of_fac_hom_app, assoc, assoc, assoc],
    dsimp only [functor.comp_map],
    nth_rewrite 3 ← functor.map_comp_assoc,
    erw [← functor.map_comp, iso.inv_hom_id_app, (functor r).map_id, F'.map_id, id_comp],
    nth_rewrite 4 ← functor.map_comp_assoc,
    erw [e.inv_hom_id_app, functor.map_id, id_comp, (shift_functor_add D a b).inv.naturality],
    refl,
  end, }

instance lift_has_comm_shift
 (hF : ∀ (x y : C) (f₁ f₂ : x ⟶ y), r f₁ f₂ → F.map f₁ = F.map f₂) :
  (lift r F hF).has_comm_shift B :=
has_comm_shift (lift.is_lift r F hF) B

end

end quotient

end category_theory


import LMT

variable {I} [Nonempty I] {E} [Nonempty E] [Nonempty (A I E)]

example {a1 a2 a3 : A I E} :
        (v3) ≠ (((((a1).write i3 (v1)).write i2 (v3)).write i1 (v3)).read i2) → False := by
  arr


import .arrow
import .cofibration_category
import tactic.slice

/- Brown factorization, aka "Ken Brown's lemma", and a relative version.
   Following Rădulescu-Banu, Cofibrations in Homotopy Theory, section 1.3. -/

universes v u

namespace homotopy_theory.cofibrations
open category_theory
open category_theory.category
open precofibration_category
open cofibration_category
open homotopy_theory.weak_equivalences

variables {C : Type u} [category.{v} C] [cofibration_category.{v} C]
  [has_initial_object.{v} C]

structure brown_factorization {a b : C} (f : a ⟶ b) : Type (max u v) :=
-- ab represents a coproduct of a and b, used to formulate the condition on f' + s
(ab : pushout (! a) (! b))
(b' : C)
(f' : a ⟶ b') (r : b' ⟶ b) (s : b ⟶ b')
(hf' : is_cof f')
(hf's : is_cof (ab.is_pushout.induced f' s (initial.uniqueness _ _)))
(hs : is_acof s)
(hf'r : f' ≫ r = f)
(hsr : s ≫ r = 𝟙 b)

lemma brown_factorization.hr {a b : C} {f : a ⟶ b} (c : brown_factorization f) :
  is_weq c.r :=
begin
  convert category_with_weak_equivalences.weq_of_comp_weq_left c.hs.2 _,
  rw c.hsr,
  apply weq_id
end

lemma brown_factorization.weq_f' {a b : C} {f : a ⟶ b} (c : brown_factorization f) (hf : is_weq f) :
  is_weq c.f' :=
begin
  convert category_with_weak_equivalences.weq_of_comp_weq_right c.hr _,
  rw c.hf'r,
  exact hf
end

--- Any map between cofibrant objects admits a Brown factorization (R-B, Lemma 1.3.1).
lemma exists_brown_factorization {a b : C} (ha : cofibrant a) (hb : cofibrant b) (f : a ⟶ b) :
  nonempty (brown_factorization f) :=
let ab := pushout_by_cof (! a) (! b) ha,
    ⟨b', j, g, hj, hg, hf⟩ :=
      factorization (ab.is_pushout.induced f (𝟙 b) (initial.uniqueness _ _)) in
⟨⟨ab, b', ab.map₀ ≫ j, g, ab.map₁ ≫ j,
  cof_comp (pushout_is_cof ab.is_pushout.transpose hb) hj,
  by convert hj; apply ab.is_pushout.uniqueness; simp,
  begin
    split,
    { refine cof_comp (pushout_is_cof ab.is_pushout ha) hj },
    { convert category_with_weak_equivalences.weq_of_comp_weq_right hg _,
      rw [assoc, hf], simpa using weq_id _ }
  end,
  by rw [assoc, hf]; simp,
  by rw [assoc, hf]; simp⟩⟩

--- R-B, Lemma 1.3.3
lemma relative_factorization {a₁ a₁' b₁ a₂ b₂ : C}
  (ha₁ : cofibrant a₁) (ha₂ : cofibrant a₂)
  (f₁' : a₁ ⟶ a₁') (r₁ : a₁' ⟶ b₁) (hf₁' : is_cof f₁') (hr : is_weq r₁)
  (f₂ : a₂ ⟶ b₂) (a : a₁ ⟶ a₂) (b : b₁ ⟶ b₂) (s : (f₁' ≫ r₁) ≫ b = a ≫ f₂) :
  ∃ a₂' (a' : a₁' ⟶ a₂') (f₂' : a₂ ⟶ a₂') (r₂ : a₂' ⟶ b₂)
  (hf' : f₁' ≫ a' = a ≫ f₂'), r₁ ≫ b = a' ≫ r₂ ∧ f₂' ≫ r₂ = f₂ ∧ is_cof f₂' ∧ is_weq r₂ ∧
  is_cof ((pushout_by_cof f₁' a hf₁').is_pushout.induced a' f₂' hf') :=
let po := pushout_by_cof f₁' a hf₁',
    g := po.is_pushout.induced (r₁ ≫ b) f₂ (by rw [←s, assoc]),
    ⟨a₂', s, r₂, hs, hr₂, hg⟩ := factorization g in
⟨a₂', po.map₀ ≫ s, po.map₁ ≫ s, r₂,
 by rw [←assoc, ←assoc, po.is_pushout.commutes],
 by rw [assoc, hg]; simp,
 by simp [hg],
 cof_comp (pushout_is_cof po.is_pushout hf₁') hs,
 hr₂,
 by convert hs; apply po.is_pushout.uniqueness; simp⟩

/-- R-B, Lemma 1.3.4. The statement there is missing hypotheses on the maps a and b,
  needed for the last two conclusions. -/
lemma exists_relative_brown_factorization {a₁ b₁ a₂ b₂ : C}
  (ha₁ : cofibrant a₁) (hb₁ : cofibrant b₁) (ha₂ : cofibrant a₂) (hb₂ : cofibrant b₂)
  (f₁ : a₁ ⟶ b₁) (f₂ : a₂ ⟶ b₂) (a : a₁ ⟶ a₂) (b : b₁ ⟶ b₂) (S : f₁ ≫ b = a ≫ f₂)
  (c₁ : brown_factorization f₁) : ∃ (c₂ : brown_factorization f₂) (b' : c₁.b' ⟶ c₂.b')
  (hf' : c₁.f' ≫ b' = a ≫ c₂.f') (hr : c₁.r ≫ b = b' ≫ c₂.r) (hs : c₁.s ≫ b' = b ≫ c₂.s),
  (is_cof b → is_cof ((pushout_by_cof c₁.f' a c₁.hf').is_pushout.induced b' c₂.f' hf')) ∧
  (is_cof a → is_acof ((pushout_by_cof c₁.s b c₁.hs.1).is_pushout.induced b' c₂.s hs)) :=
let po_a := pushout_by_cof c₁.f' a c₁.hf',
    a₃ := po_a.ob,
    f' := po_a.map₁,
    cof_f' : is_cof f' := pushout_is_cof po_a.is_pushout c₁.hf',
    po_b := pushout_by_cof c₁.s b c₁.hs.1,
    b₃ := po_b.ob,
    s := po_b.map₁,
    acof_s : is_acof s := pushout_is_acof po_b.is_pushout c₁.hs,
    r := po_b.is_pushout.induced (c₁.r ≫ b) (𝟙 _) (by rw [←assoc, c₁.hsr]; simp),
    f₃ : a₃ ⟶ b₃ := po_a.is_pushout.induced (c₁.r ≫ b ≫ s) (f₂ ≫ s) begin
      conv { to_rhs, rw [←assoc, ←S], rw [←c₁.hf'r, assoc] }, simp
    end,
    a₂b₂ := pushout_by_cof (! a₂) (! b₂) ha₂,
    -- TODO: lemma here?
    cof_a₃ : cofibrant a₃ := begin
      change is_cof _,
      convert cof_comp ha₂ (pushout_is_cof po_a.is_pushout c₁.hf'),
      apply initial.uniqueness
    end,
    cof_b₃ : cofibrant b₃ := begin
      change is_cof _,
      convert cof_comp hb₂ (pushout_is_cof po_b.is_pushout c₁.hs.1),
      apply initial.uniqueness
    end,
    a₃b₃ := pushout_by_cof (! a₃) (! b₃) cof_a₃,
    a₁_b₁ := c₁.ab.ob,
    cof_a₁_b₁ : cofibrant a₁_b₁ := begin
      change is_cof _,
      convert cof_comp hb₁ (pushout_is_cof c₁.ab.is_pushout ha₁),
      apply initial.uniqueness
    end,
    a₃_b₃ := a₃b₃.ob,
    cof_a₃_b₃ : cofibrant a₃_b₃ := begin
      change is_cof _,
      convert cof_comp cof_b₃ (pushout_is_cof a₃b₃.is_pushout cof_a₃),
      apply initial.uniqueness
    end,
    ⟨b₂', b', fs₃', r₃, hfs₃', hr₃, hf'sr, cof_fs₃', weq_r₃, cof_p⟩ := begin
      refine relative_factorization cof_a₁_b₁ cof_a₃_b₃ _ c₁.r c₁.hf's c₁.hr
        (a₃b₃.is_pushout.induced f₃ (𝟙 b₃) (initial.uniqueness _ _))
        (pushout_of_maps c₁.ab.is_pushout a₃b₃.is_pushout (𝟙 _) (a ≫ f') (b ≫ s)
          (initial.uniqueness _ _) (initial.uniqueness _ _))
        (b ≫ s) _,
      apply c₁.ab.is_pushout.uniqueness,
      { slice_lhs 1 2 { simp }, conv { to_lhs, rw [c₁.hf'r, S, assoc] },
        rw induced_pushout_of_maps, simp },
      { slice_lhs 1 2 { simp }, conv { to_lhs, rw [c₁.hsr, id_comp] },
        rw induced_pushout_of_maps, simp }
    end,
    f₃' := a₃b₃.map₀ ≫ fs₃',
    s₃ := a₃b₃.map₁ ≫ fs₃',
    f₂' := f' ≫ f₃',
    r₂ := r₃ ≫ r,
    s₂ := s ≫ s₃ in
have sr : s ≫ r = 𝟙 _, by simp,
have s₂r₂ : s₂ ≫ r₂ = 𝟙 _, begin
  slice_lhs 3 4 { rw hf'sr },
  slice_lhs 2 3 { rw Is_pushout.induced_commutes₁ },
  simp
end,
have weq_r₂ : is_weq r₂, begin
  refine weq_comp weq_r₃ _,
  rw ←weq_iff_weq_inv sr,
  exact acof_s.2
end,
⟨⟨a₂b₂, b₂', f₂', r₂, s₂,
  cof_comp (pushout_is_cof po_a.is_pushout c₁.hf')
    (cof_comp (pushout_is_cof a₃b₃.is_pushout.transpose cof_b₃) cof_fs₃'),
  begin
    have := cof_pushout cof_f' acof_s.1 a₂b₂.is_pushout
      (by convert a₃b₃.is_pushout; apply initial.uniqueness) (by apply initial.uniqueness),
    convert cof_comp this cof_fs₃',
    apply a₂b₂.is_pushout.uniqueness; conv { to_rhs, rw ←assoc }; simp
  end,
  begin
    refine ⟨_, (weq_iff_weq_inv s₂r₂).mpr weq_r₂⟩,
    exact cof_comp acof_s.1 (cof_comp (pushout_is_cof a₃b₃.is_pushout cof_a₃) cof_fs₃')
  end,
  begin
    slice_lhs 3 4 { rw hf'sr },
    slice_lhs 2 3 { rw Is_pushout.induced_commutes₀ },
    slice_lhs 1 2 { rw Is_pushout.induced_commutes₁ },
    simp [sr]
  end,
  s₂r₂⟩,
 b',
 begin
   convert congr_arg (λ z, c₁.ab.map₀ ≫ z) hfs₃' using 1,
   { slice_rhs 1 2 { rw Is_pushout.induced_commutes₀ } },
   { slice_rhs 1 2 { dsimp [pushout_of_maps], rw Is_pushout.induced_commutes₀ }, simp }
 end,
 begin
   have : c₁.r ≫ b = c₁.r ≫ b ≫ (s ≫ r), by rw [sr]; simp,
   rw this,
   slice_lhs 1 3 { rw hr₃ },
   simp
 end,
 begin
   convert congr_arg (λ z, c₁.ab.map₁ ≫ z) hfs₃' using 1,
   { slice_rhs 1 2 { rw Is_pushout.induced_commutes₁ } },
   { slice_rhs 1 2 { dsimp [pushout_of_maps], rw Is_pushout.induced_commutes₁ }, simp }
 end,
 begin
   intro hb,
   let v := _,
   let S₂ : cof_square v b' := ⟨_, _, _, _, cof_p⟩,
   let S₁ : cof_square a v,
   { refine ⟨c₁.ab.map₀, f' ≫ a₃b₃.map₀,
       by simp [v, pushout_of_maps], pushout_is_cof c₁.ab.is_pushout.transpose hb₁, _⟩,
     let po : pushout _ _ := _,
     change is_cof (po.is_pushout.induced _ _ _),
     have : is_cof (b ≫ s) := cof_comp hb acof_s.1,
     convert cof_pushout this cof_f'
       (Is_pushout_of_Is_pushout_of_Is_pushout c₁.ab.is_pushout.transpose po.is_pushout)
       (by convert a₃b₃.is_pushout.transpose; apply initial.uniqueness)
       (by apply initial.uniqueness) using 1,
     symmetry,
     apply pushout_induced_eq_iff; simp },
   have : c₁.f' = S₁.f₁ ≫ S₂.f₁, by simp,
   have S : is_cof_square a b' c₁.f' _ :=
     is_cof_square_comp ⟨S₁, rfl, rfl⟩ ⟨S₂, rfl, rfl⟩ this rfl,
   convert S.corner_cof.snd.snd,
   simp
 end,
 begin
   intro ha,
   let G := _,
   change is_acof G,
   suffices : is_cof G,
   { refine ⟨this, _⟩,
     have sG : s ≫ G = s₂, by simp,
     have : is_acof s := pushout_is_acof po_b.is_pushout c₁.hs,
     refine category_with_weak_equivalences.weq_of_comp_weq_left this.2 _,
     rw sG,
     exact (weq_iff_weq_inv s₂r₂).mpr weq_r₂ },
   -- From here on, the proof resembles the previous one
   let v := _,
   let S₂ : cof_square v b' := ⟨_, _, _, _, cof_p⟩,
   let S₁ : cof_square b v,
   { refine ⟨c₁.ab.map₁, s ≫ a₃b₃.map₁,
       by simp [v, pushout_of_maps], pushout_is_cof c₁.ab.is_pushout ha₁, _⟩,
     let po : pushout _ _ := _,
     change is_cof (po.is_pushout.induced _ _ _),
     have : is_cof (a ≫ f') := cof_comp ha cof_f',
     convert cof_pushout this acof_s.1
       (Is_pushout_of_Is_pushout_of_Is_pushout c₁.ab.is_pushout po.is_pushout)
       (by convert a₃b₃.is_pushout; apply initial.uniqueness)
       (by apply initial.uniqueness) using 1,
     symmetry,
     apply pushout_induced_eq_iff; simp },
   have : c₁.s = S₁.f₁ ≫ S₂.f₁, by simp,
   have S : is_cof_square b b' c₁.s _ :=
     is_cof_square_comp ⟨S₁, rfl, rfl⟩ ⟨S₂, rfl, rfl⟩ this rfl,
   convert S.corner_cof.snd.snd,
   simp
 end⟩

end homotopy_theory.cofibrations