import data.cpi.concretion.congruence

namespace cpi
namespace concretion

variables {ℍ : Type} {ω : context}

/-- An alternative measure, simply computes the depth of a term, and thus is
    preserved over renames. -/
private def depth : ∀ {Γ} {b y}, concretion ℍ ω Γ b y → ℕ
| _ _ _ (#(_; _) _) := 1
| _ _ _ (F |₁ _) := depth F + 1
| _ _ _ (_ |₂ F) := depth F + 1
| _ _ _ (ν'(M) F) := depth F + 1

private theorem depth.over_rename :
  ∀ {Γ Δ} {b y} (ρ : name Γ → name Δ) (F : concretion ℍ ω Γ b y)
  , depth F = depth (rename ρ F)
| Γ Δ b y ρ (#(_; _) _) := by unfold rename depth
| Γ Δ b y ρ (F |₁ A) := by { unfold rename depth, rw depth.over_rename ρ F }
| Γ Δ b y ρ (A |₂ F) := by { unfold rename depth, rw depth.over_rename ρ F }
| Γ Δ b y ρ (ν'(M) F) :=
  by { unfold rename depth, rw depth.over_rename (name.ext ρ) F }

/-- Helper function for doign the actual application. This is split up to
    make the totality of pseudo_apply/pseudo_apply_app easier to determine. -/
private def pseudo_apply_app {a b} :
  ∀ {Γ}, vector (name Γ) a → species ℍ ω (context.extend b Γ)
  → concretion ℍ ω Γ b a → species ℍ ω Γ
| Γ as A (#(bs; y) B) :=
  species.rename (name.mk_apply bs) A |ₛ species.rename (name.mk_apply as) B
| Γ as A (F |₁ B) :=
    pseudo_apply_app as A F |ₛ B
| Γ as A (B |₂ F) :=
    B |ₛ pseudo_apply_app as A F
| Γ as A (ν'(M) F) :=
  ν(M) (pseudo_apply_app
          (vector.map name.extend as)
          (species.rename (name.ext name.extend) A)
          F)
using_well_founded {
  rel_tac := λ _ _,
    `[exact ⟨_, measure_wf (λ x, concretion.sizeof ℍ ω x.fst b a x.snd.snd.snd ) ⟩ ],
  dec_tac := tactic.fst_dec_tac,
}

/-- Apply two concretions together. -/
def pseudo_apply {a b} : ∀ {Γ}, concretion ℍ ω Γ a b → concretion ℍ ω Γ b a → species ℍ ω Γ
| Γ (#(bs; y) A) F' := pseudo_apply_app bs A F'
| Γ (F |₁ A) F' := pseudo_apply F F' |ₛ A
| Γ (A |₂ F) F' := A |ₛ pseudo_apply F F'
| Γ (ν'(M) F) F' := ν(M) (pseudo_apply F (rename name.extend F'))
using_well_founded {
  rel_tac := λ _ _,
    `[exact ⟨_, measure_wf (λ x, concretion.sizeof ℍ ω x.fst a b x.snd.fst ) ⟩ ],
  dec_tac := tactic.fst_dec_tac,
}

open species.equiv (hiding trans symm refl)
open_locale congruence

protected lemma pseudo_apply.on_parallel₁ :
  ∀ {Γ} {a b} (F : concretion ℍ ω Γ a b) (G : concretion ℍ ω Γ b a) (A : species ℍ ω Γ)
  , pseudo_apply F (G |₁ A) ≈ (pseudo_apply F G |ₛ A)
| Γ a b (#(bs; y) A) G B := by unfold pseudo_apply pseudo_apply_app
| Γ a b (F |₁ B) G A := begin
    unfold pseudo_apply,
    calc  (pseudo_apply F (G |₁ A) |ₛ B)
        ≈ ((pseudo_apply F G |ₛ A) |ₛ B)
          : ξ_parallel₁ (pseudo_apply.on_parallel₁ F G A)
    ... ≈ ((pseudo_apply F G |ₛ B) |ₛ A) : parallel_symm₂
  end
| Γ a b (B |₂ F) G A := begin
    unfold pseudo_apply,
    calc  (B |ₛ pseudo_apply F (G |₁ A))
        ≈ (B |ₛ pseudo_apply F G |ₛ A)
          : ξ_parallel₂ (pseudo_apply.on_parallel₁ F G A)
    ... ≈ ((B |ₛ pseudo_apply F G) |ₛ A) : parallel_assoc₂
  end
| Γ a b (ν'(M) F) G A := begin
    unfold pseudo_apply rename,
    calc  (ν(M) pseudo_apply F (rename name.extend G |₁ species.rename name.extend A))
        ≈ (ν(M) pseudo_apply F (rename name.extend G) |ₛ species.rename name.extend A)
          : ξ_restriction M (pseudo_apply.on_parallel₁ F _ _)
    ... ≈ ((ν(M) pseudo_apply F (rename name.extend G)) |ₛ A) : ν_parallel' M
  end

protected lemma pseudo_apply.on_parallel₂ :
  ∀ {Γ} {a b} (F : concretion ℍ ω Γ a b) (A : species ℍ ω Γ) (G : concretion ℍ ω Γ b a)
  , pseudo_apply F (A |₂ G) ≈ (A |ₛ pseudo_apply F G)
| Γ a b (#(bs; y) A) B F := by unfold pseudo_apply pseudo_apply_app
| Γ a b (F |₁ B) A G := begin
    unfold pseudo_apply,
    calc  (pseudo_apply F (A |₂ G) |ₛ B)
        ≈ ((A |ₛ pseudo_apply F G) |ₛ B)
          : ξ_parallel₁ (pseudo_apply.on_parallel₂ F A G)
    ... ≈ (A |ₛ pseudo_apply F G |ₛ B) : parallel_assoc₁
  end
| Γ a b (B |₂ F) A G := begin
    unfold pseudo_apply,
    calc  (B |ₛ pseudo_apply F (A |₂ G))
        ≈ (B |ₛ A |ₛ pseudo_apply F G)
          : ξ_parallel₂ (pseudo_apply.on_parallel₂ F A G)
    ... ≈ (A |ₛ B |ₛ pseudo_apply F G) : parallel_symm₁
  end
| Γ a b (ν'(M) F) A G := begin
    unfold pseudo_apply rename,
    calc  (ν(M) pseudo_apply F (species.rename name.extend A |₂ rename name.extend G))
        ≈ (ν(M) species.rename name.extend A |ₛ pseudo_apply F (rename name.extend G))
          : ξ_restriction M (pseudo_apply.on_parallel₂ F _ _)
    ... ≈ (A |ₛ ν(M) pseudo_apply F (rename name.extend G)) : ν_parallel₁ M
  end

-- TODO: Clean up to use calc
-- TODO: Use induction - does this allow us to drop the explicit termination
-- checks?

private lemma pseudo_apply_app.rename {a b} :
  ∀ {Γ Δ} (ρ : name Γ → name Δ)
    (as : vector (name Γ) a) (A : species ℍ ω (context.extend b Γ))
    (F : concretion ℍ ω Γ b a)
  , species.rename ρ (pseudo_apply_app as A F)
  = pseudo_apply_app (vector.map ρ as) (species.rename (name.ext ρ) A) (rename ρ F)
| Γ Δ ρ as A (#(bs; y) B) := begin
    unfold pseudo_apply_app rename,
    simp [species.rename_compose, name.mk_apply_rename]
  end
| Γ Δ ρ bs A (F |₁ B) := begin
    unfold pseudo_apply_app rename,
    simp [pseudo_apply_app.rename ρ bs A F]
  end
| Γ Δ ρ bs A (B |₂ F) := begin
    unfold pseudo_apply_app rename,
    simp [pseudo_apply_app.rename ρ bs A F]
  end
| Γ Δ ρ ⟨ bs, n ⟩ A (ν'(M) G) := begin
    unfold pseudo_apply_app rename,
    simp,
    have map
      : vector.map (@name.extend _ M.arity) (vector.map ρ ⟨bs, n⟩)
      = vector.map (name.ext ρ) (vector.map name.extend ⟨bs, n⟩),
      unfold vector.map, simp, rw ← name.ext_extend ρ,
    rw map,

    have spc
      : species.rename (name.ext (@name.extend _ M.arity)) (species.rename (name.ext ρ) A)
      = species.rename (name.ext (name.ext ρ)) (species.rename (name.ext name.extend) A),
      rw [species.rename_compose, species.rename_compose],
      rw [name.ext_comp, name.ext_comp],
      rw name.ext_extend ρ,
    rw spc,

    from pseudo_apply_app.rename (name.ext ρ) _ _ G,
  end
using_well_founded {
  rel_tac := λ _ _,
    `[exact ⟨_, measure_wf (λ x, concretion.sizeof ℍ ω x.fst b a x.snd.snd.snd.snd.snd ) ⟩ ],
  dec_tac := tactic.fst_dec_tac,
}

protected lemma pseudo_apply.rename {a b} :
  ∀ {Γ Δ} (ρ : name Γ → name Δ)
    (F : concretion ℍ ω Γ a b) (G : concretion ℍ ω Γ b a)
  , species.rename ρ (pseudo_apply F G) = pseudo_apply (rename ρ F) (rename ρ G)
| Γ Δ ρ (#(bs; y) A) G := begin
    unfold pseudo_apply rename,
    from pseudo_apply_app.rename ρ bs A G
  end
| Γ Δ ρ (F |₁ A) G := begin
    unfold pseudo_apply rename,
    simp [pseudo_apply.rename ρ F G]
  end
| Γ Δ ρ (A |₂ F) G := begin
    unfold pseudo_apply rename,
    simp [pseudo_apply.rename ρ F G]
  end
| Γ Δ ρ (ν'(M) F) G := begin
    unfold pseudo_apply rename, simp,
    -- -- TODO: Clean up to use calc
    rw rename_compose,
    rw ← name.ext_extend,
    rw ← rename_compose name.extend,
    rw pseudo_apply.rename (name.ext ρ) F _,
  end
using_well_founded {
  rel_tac := λ _ _,
    `[exact ⟨_, measure_wf (λ x, concretion.sizeof ℍ ω x.fst a b x.snd.snd.snd.fst ) ⟩ ],
  dec_tac := tactic.fst_dec_tac,
}

private lemma pseudo_apply.restriction_swap {a b}:
  ∀ {Γ} (M N : affinity ℍ)
    (F : concretion ℍ ω (context.extend N.arity Γ) a b)
    (G : concretion ℍ ω (context.extend M.arity Γ) b a)
  , (ν(N) ν(M) pseudo_apply (rename name.extend F) (rename (name.ext name.extend) G))
  ≈ ν(M) ν(N) pseudo_apply (rename (name.ext name.extend) F) (rename name.extend G)
| Γ M N F G :=
    calc  (ν(N) ν(M) pseudo_apply (rename name.extend F) (rename (name.ext name.extend) G))
        ≈ (ν(M) ν(N) species.rename name.swap (pseudo_apply (rename name.extend F) (rename (name.ext name.extend) G)))
          : ν_swap₁ N M
    ... ≈ (ν(M) ν(N) (pseudo_apply (rename name.swap (rename name.extend F)) (rename name.swap (rename (name.ext name.extend) G))))
          : by rw pseudo_apply.rename
    ... ≈ (ν(M) ν(N) (pseudo_apply (rename (name.swap ∘ name.extend) F) (rename (name.swap ∘ name.ext name.extend) G)))
          : by rw [rename_compose, rename_compose]
    ... ≈ ν(M) ν(N) pseudo_apply (rename (name.ext name.extend) F) (rename name.extend G)
          : by rw [name.swap_comp_extend, name.swap_comp_ext_extend]

lemma pseudo_apply.on_restriction :
  ∀ {Γ} {a b} (F : concretion ℍ ω Γ a b) (M : affinity ℍ)
    (G : concretion ℍ ω (context.extend M.arity Γ) b a)
  , pseudo_apply F (ν'(M) G) ≈ ν(M) (pseudo_apply (rename name.extend F) G)
| Γ a b (#(bs; y) A) M G := by unfold pseudo_apply pseudo_apply_app rename
| Γ a b (F |₁ A) M G := begin
    unfold pseudo_apply rename,
    calc  (pseudo_apply F (ν'(M) G) |ₛ A)
        ≈ ((ν(M) pseudo_apply (rename name.extend F) G) |ₛ A)
          : ξ_parallel₁ (pseudo_apply.on_restriction F M G)
    ... ≈ ν(M) pseudo_apply (rename name.extend F) G |ₛ species.rename name.extend A
          : symm (ν_parallel' M),
  end
| Γ a b (A |₂ F) M G := begin
    unfold pseudo_apply rename,
    calc  (A |ₛ pseudo_apply F (ν'(M) G))
        ≈ (A |ₛ ν(M) pseudo_apply (rename name.extend F) G)
          : ξ_parallel₂ (pseudo_apply.on_restriction F M G)
    ... ≈ ν(M) species.rename name.extend A |ₛ pseudo_apply (rename name.extend F) G
          : ν_parallel₂ M,
  end
| Γ a b (ν'(N) F) M G := begin
    unfold pseudo_apply rename,
    calc  (ν(N) pseudo_apply F (ν'(M) rename (name.ext name.extend) G))
        ≈ (ν(N) ν(M) pseudo_apply (rename name.extend F) (rename (name.ext name.extend) G))
          : ξ_restriction N (pseudo_apply.on_restriction F M _)
    ... ≈ ν(M) ν(N) pseudo_apply (rename (name.ext name.extend) F) (rename name.extend G)
          : pseudo_apply.restriction_swap M N F G
  end

private theorem pseudo_apply_app.symm {a b} :
  ∀ {Γ} (bs : vector (name Γ) a) (A : species ℍ ω (context.extend b Γ))
    (G : concretion ℍ ω Γ b a)
  , pseudo_apply_app bs A G ≈ pseudo_apply G (#(bs; b) A) := begin
  intros Γ as A G,
  induction G,

  case apply : Γ' b' bs y A {
    unfold pseudo_apply pseudo_apply_app,
    from parallel_symm
  },

  case parallel₁ : Γ' b' y F A ih {
      unfold pseudo_apply pseudo_apply_app,
      from ξ_parallel₁ (ih _ _)
  },

  case parallel₂ : Γ' b' y A F ih {
      unfold pseudo_apply pseudo_apply_app,
      from ξ_parallel₂ (ih _ _)
  },

  case restriction : Γ' b' y M F ih {
    unfold pseudo_apply pseudo_apply_app,
    from ξ_restriction M (ih _ _)
  }
end

theorem pseudo_apply.symm {a b} :
  ∀ {Γ} (F : concretion ℍ ω Γ a b) (G : concretion ℍ ω Γ b a)
  , pseudo_apply F G ≈ pseudo_apply G F
| Γ (#(as; x) A) G := begin
    unfold pseudo_apply,
    from pseudo_apply_app.symm as A G
  end

| Γ (F |₁ A) (#(bs; y) B) := begin
    unfold pseudo_apply pseudo_apply_app,
    from ξ_parallel₁ (symm (pseudo_apply_app.symm bs B F)),
  end
| Γ (F |₁ A) (G |₁ B) := begin
    unfold pseudo_apply,
    calc  (pseudo_apply F (G |₁ B) |ₛ A)
        ≈ ((pseudo_apply F G |ₛ B) |ₛ A)
          : ξ_parallel₁ (pseudo_apply.on_parallel₁ F G B)
    ... ≈ ((pseudo_apply G F |ₛ B) |ₛ A)
          : ξ_parallel₁ (ξ_parallel₁ (pseudo_apply.symm F G))
    ... ≈ ((pseudo_apply G F |ₛ A) |ₛ B) : parallel_symm₂
    ... ≈ (pseudo_apply G (F |₁ A) |ₛ B)
          : ξ_parallel₁ (symm (pseudo_apply.on_parallel₁ G F A))
  end
| Γ (F |₁ A) (B |₂ G) := begin
    unfold pseudo_apply,
    calc  (pseudo_apply F (B |₂ G) |ₛ A)
        ≈ ((B |ₛ pseudo_apply F G) |ₛ A)
          : ξ_parallel₁ (pseudo_apply.on_parallel₂ F B G)
    ... ≈ (B |ₛ pseudo_apply F G |ₛ A) : parallel_assoc₁
    ... ≈ (B |ₛ pseudo_apply G F |ₛ A)
          : ξ_parallel₂ (ξ_parallel₁ (pseudo_apply.symm F G))
    ... ≈ (B |ₛ pseudo_apply G (F |₁ A))
          : ξ_parallel₂ (symm (pseudo_apply.on_parallel₁ G F A))
  end
| Γ (F |₁ A) (ν'(M) G) := begin
    unfold pseudo_apply rename,
    calc  (pseudo_apply F (ν'(M) G) |ₛ A)
        ≈ ((ν(M) pseudo_apply (rename name.extend F) G) |ₛ A)
          : ξ_parallel₁ (pseudo_apply.on_restriction F M G)
    ... ≈ ((ν(M) pseudo_apply G (rename name.extend F)) |ₛ A)
          : ξ_parallel₁ (ξ_restriction M (pseudo_apply.symm _ G))
    ... ≈ (ν(M) (pseudo_apply G (rename name.extend F)) |ₛ species.rename name.extend A)
          : symm (ν_parallel' M)
    ... ≈ ν(M) pseudo_apply G (rename name.extend F |₁ species.rename name.extend A)
          : ξ_restriction M (symm (pseudo_apply.on_parallel₁ G _ _))
  end

| Γ (A |₂ F) (#(bs; y) B) := begin
    unfold pseudo_apply pseudo_apply_app,
    from ξ_parallel₂ (symm (pseudo_apply_app.symm bs B F)),
  end
| Γ (A |₂ F) (G |₁ B) := begin
    unfold pseudo_apply,
    calc  (A |ₛ pseudo_apply F (G |₁ B))
        ≈ (A |ₛ pseudo_apply F G |ₛ B)
          : ξ_parallel₂ (pseudo_apply.on_parallel₁ F G B)
    ... ≈ (A |ₛ pseudo_apply G F |ₛ B)
          : ξ_parallel₂ (ξ_parallel₁ (pseudo_apply.symm F G))
    ... ≈ ((A |ₛ pseudo_apply G F) |ₛ B) : parallel_assoc₂
    ... ≈ (pseudo_apply G (A |₂ F) |ₛ B)
          : ξ_parallel₁ (symm (pseudo_apply.on_parallel₂ G A F))
  end
| Γ (A |₂ F) (B |₂ G) := begin
    unfold pseudo_apply,
    calc  (A |ₛ pseudo_apply F (B |₂ G))
        ≈ (A |ₛ B |ₛ pseudo_apply F G)
          : ξ_parallel₂ (pseudo_apply.on_parallel₂ F B G)
    ... ≈ (B |ₛ A |ₛ pseudo_apply F G) : parallel_symm₁
    ... ≈ (B |ₛ A |ₛ pseudo_apply G F)
          : ξ_parallel₂ (ξ_parallel₂ (pseudo_apply.symm F G))
    ... ≈ (B |ₛ pseudo_apply G (A |₂ F))
          : ξ_parallel₂ (symm (pseudo_apply.on_parallel₂ G A F))
  end
| Γ (A |₂ F) (ν'(M) G) := begin
    unfold pseudo_apply rename,
    calc  (A |ₛ pseudo_apply F (ν'(M) G))
        ≈ (A |ₛ ν(M) pseudo_apply (rename name.extend F) G)
          : ξ_parallel₂ (pseudo_apply.on_restriction F M G)
    ... ≈ ν(M) species.rename name.extend A |ₛ pseudo_apply (rename name.extend F) G
          : ν_parallel₂ M
    ... ≈ ν(M) species.rename name.extend A |ₛ pseudo_apply G (rename name.extend F)
          : ξ_restriction M (ξ_parallel₂ (pseudo_apply.symm _ G))
    ... ≈ ν(M) pseudo_apply G (species.rename name.extend A |₂ rename name.extend F)
          : ξ_restriction M (symm (pseudo_apply.on_parallel₂ G _ _))
end

| Γ (ν'(M) F) (#(bs; y) B) := begin
    unfold pseudo_apply pseudo_apply_app,
    from ξ_restriction M (symm (pseudo_apply_app.symm _ _ F)),
  end
| Γ (ν'(M) F) (G |₁ B) :=
  let h : depth (rename (@name.extend Γ M.arity) G) < depth G + 1 := begin
    rw ← depth.over_rename name.extend G,
    from nat.lt_add_of_pos_right nat.zero_lt_one
  end in begin
    unfold pseudo_apply rename,
    calc  (ν(M) pseudo_apply F (rename name.extend G |₁ species.rename name.extend B))
        ≈ (ν(M) pseudo_apply F (rename name.extend G) |ₛ species.rename name.extend B)
          : ξ_restriction M (pseudo_apply.on_parallel₁ F _ _)
    ... ≈ ((ν(M) pseudo_apply F (rename name.extend G)) |ₛ B) : ν_parallel' M
    ... ≈ ((ν(M) pseudo_apply (rename name.extend G) F) |ₛ B)
          : ξ_parallel₁ (ξ_restriction M (pseudo_apply.symm F (rename name.extend G)))
    ... ≈ (pseudo_apply G (ν'(M) F) |ₛ B)
          : ξ_parallel₁ (symm (pseudo_apply.on_restriction G M F))
  end
| Γ (ν'(M) F) (B |₂ G) :=
  let h : depth (rename (@name.extend Γ M.arity) G) < depth G + 1 := begin
    rw ← depth.over_rename name.extend G,
    from nat.lt_add_of_pos_right nat.zero_lt_one
  end in begin
    unfold pseudo_apply rename,
    calc  (ν(M) pseudo_apply F (species.rename name.extend B |₂ rename name.extend G))
        ≈ (ν(M) species.rename name.extend B |ₛ pseudo_apply F (rename name.extend G))
          : ξ_restriction M (pseudo_apply.on_parallel₂ F _ _)
    ... ≈ (B |ₛ ν(M) pseudo_apply F (rename name.extend G)) : ν_parallel₁ M
    ... ≈ (B |ₛ ν(M) pseudo_apply (rename name.extend G) F)
          : ξ_parallel₂ (ξ_restriction M (pseudo_apply.symm F _))
    ... ≈ (B |ₛ pseudo_apply G (ν'(M) F))
          : ξ_parallel₂ (symm (pseudo_apply.on_restriction G M F))
  end
| Γ (ν'(M) F) (ν'(N) G) :=
  let h : depth (rename (name.ext (@name.extend Γ M.arity)) G) < depth G + 1 := begin
    rw ← depth.over_rename _ G,
    from nat.lt_add_of_pos_right nat.zero_lt_one
  end in begin
    unfold pseudo_apply rename,
    calc  (ν(M) pseudo_apply F (ν'(N) rename (name.ext name.extend) G))
        ≈ (ν(M) ν(N) pseudo_apply (rename name.extend F) (rename (name.ext name.extend) G))
          : ξ_restriction M (pseudo_apply.on_restriction F N _)
    ... ≈ (ν(M) ν(N) pseudo_apply (rename (name.ext name.extend) G) (rename name.extend F))
          : ξ_restriction M (ξ_restriction N (pseudo_apply.symm _ _))
    ... ≈ ν(N) ν(M) pseudo_apply (rename name.extend G) (rename (name.ext name.extend) F)
          : symm (pseudo_apply.restriction_swap M N G F)
    ... ≈ ν(N) pseudo_apply G (ν'(M) rename (name.ext name.extend) F)
          : ξ_restriction N (symm (pseudo_apply.on_restriction G M _))
  end
using_well_founded {
  rel_tac := λ _ _,
    `[exact ⟨_, measure_wf (λ x, depth x.snd.snd ) ⟩ ],
  dec_tac := do
    well_founded_tactics.unfold_wf_rel,
    well_founded_tactics.unfold_sizeof,

    tactic.dunfold_target [``depth, ``psigma.fst, ``psigma.snd],
    well_founded_tactics.cancel_nat_add_lt,
    tactic.try well_founded_tactics.trivial_nat_lt
}

private lemma pseudo_apply_app.equiv {a b} :
  ∀ {Γ} {bs : vector (name Γ) a} {A A' : species ℍ ω (context.extend b Γ)}
    {F : concretion ℍ ω Γ b a}
  , A ≈ A' → pseudo_apply_app bs A F ≈ pseudo_apply_app bs A' F :=
begin
  intros Γ as A A' G eq,
  induction G,

  case apply : Γ b bs y B {
    unfold pseudo_apply_app,
    from ξ_parallel₁ (species.equiv.rename _ eq),
  },
  case parallel₁ : Γ b y F B ih {
    unfold pseudo_apply_app,
    from ξ_parallel₁ (ih eq)
  },
  case parallel₂ : Γ b y B F ih {
    unfold pseudo_apply_app,
    from ξ_parallel₂ (ih eq)
  },
  case restriction : Γ b y M F ih {
    unfold pseudo_apply_app,
    from ξ_restriction M (ih (species.equiv.rename _ eq)),
  }
end

private lemma pseudo_apply_app.par {a b} :
  ∀ {Γ} (bs : vector (name Γ) a)
    (A : species ℍ ω Γ) (B : species ℍ ω (context.extend b Γ))
    (G : concretion ℍ ω Γ b a)
  , pseudo_apply_app bs (species.rename name.extend A |ₛ B) G ≈ (A |ₛ pseudo_apply_app bs B G) :=
begin
  intros Γ as A B G,
  induction G,

  case apply : _ b' bs y C {
    unfold pseudo_apply_app, simp,
    calc  ((species.rename (name.mk_apply bs) (species.rename name.extend A) |ₛ species.rename (name.mk_apply bs) B)
            |ₛ species.rename (name.mk_apply as) C)
        ≈ ((species.rename (name.mk_apply bs ∘ name.extend) A |ₛ species.rename (name.mk_apply bs) B)
            |ₛ species.rename (name.mk_apply as) C)
          : by rw species.rename_compose _ _ A
    ... ≈ ((A |ₛ species.rename (name.mk_apply bs) B) |ₛ species.rename (name.mk_apply as) C)
          : by { rw [name.mk_apply_ext, species.rename_id], }
    ... ≈ (A |ₛ species.rename (name.mk_apply bs) B |ₛ species.rename (name.mk_apply as) C)
          : parallel_assoc₁
  },

  case parallel₁ : _ b' y G C ih {
    unfold pseudo_apply_app species.rename,
    calc  (pseudo_apply_app as (species.rename name.extend A |ₛ B) G |ₛ C)
        ≈ ((A |ₛ pseudo_apply_app as B G) |ₛ C) : ξ_parallel₁ (ih as A B)
    ... ≈ (A |ₛ pseudo_apply_app as B G |ₛ C) : parallel_assoc₁
  },

  case parallel₂ : _ b' y C G ih {
    unfold pseudo_apply_app species.rename,
    calc  (C |ₛ pseudo_apply_app as (species.rename name.extend A |ₛ B) G)
        ≈ (C |ₛ (A |ₛ pseudo_apply_app as B G)) : ξ_parallel₂ (ih as A B)
    ... ≈ (A |ₛ C |ₛ pseudo_apply_app as B G) : parallel_symm₁
  },

  case restriction : _ b' y' M G ih {
    unfold pseudo_apply_app, simp,
    calc  (ν(M) pseudo_apply_app (vector.map name.extend as)
                  (species.rename (name.ext name.extend) (species.rename name.extend A)
                  |ₛ species.rename (name.ext name.extend) B) G)
        ≈ (ν(M) pseudo_apply_app (vector.map name.extend as)
                  (species.rename name.extend (species.rename name.extend A)
                  |ₛ species.rename (name.ext name.extend) B) G)
          : by rw ← species.rename_ext A
    ... ≈ (ν(M) species.rename name.extend A |ₛ
                pseudo_apply_app (vector.map name.extend as)
                    (species.rename (name.ext name.extend) B) G)
          : ξ_restriction M (ih _ _ _)
    ... ≈ (A |ₛ ν(M)
                pseudo_apply_app (vector.map name.extend as)
                    (species.rename (name.ext name.extend) B) G)
        : ν_parallel₁ M
  }
end

lemma pseudo_apply.equiv_l {a b} :
  ∀ {Γ} {F F' : concretion ℍ ω Γ a b} {G : concretion ℍ ω Γ b a}
  , F ≈ F' → pseudo_apply F G ≈ pseudo_apply F' G :=
begin
  intros Γ F F' G eq, induction eq,

  -- Modifiers are incredibly trivial
  case equiv.refl { from refl _ },
  case equiv.trans : Γ b y F G H fg gh ih_fg ih_gh { from trans ih_fg ih_gh },
  case equiv.symm : Γ b y F G eq ih_eq { from symm ih_eq },

  -- Projections are trivial
  case equiv.ξ_parallel₁ : Γ b y F F' A eq ih {
    unfold pseudo_apply,
    from ξ_parallel₁ ih
  },
  case equiv.ξ_parallel₂ : Γ b y A F F' eq ih {
    unfold pseudo_apply,
    from ξ_parallel₂ ih
  },
  case equiv.ξ_restriction : Γ b y M F F' eq ih {
    unfold pseudo_apply,
    from ξ_restriction M ih
  },

  -- Now for the interesting stuff. Well, relatively speaking.

  case equiv.parallel_nil : Γ b y F { unfold pseudo_apply, from parallel_nil₁ },
  case equiv.parallel_symm : Γ b y F G { unfold pseudo_apply, from parallel_symm },
  case equiv.parallel_assoc₁ : Γ b y F A B {
    unfold pseudo_apply,
    from parallel_assoc₁
  },
  case equiv.parallel_assoc₂ : Γ b y F A B {
    unfold pseudo_apply,
    from parallel_assoc₁
  },

  case equiv.ξ_apply : Γ b y bs A A' eq F {
    unfold pseudo_apply,
    from pseudo_apply_app.equiv eq
  },
  case equiv.ξ_parallel : Γ b y F A A' eq {
    unfold pseudo_apply,
    from ξ_parallel₂ eq
  },

  case equiv.ν_parallel₁ : Γ b y M A F {
    unfold pseudo_apply,
    from ν_parallel₁ M
  },
  case equiv.ν_parallel₂ : Γ b y M F F {
    unfold pseudo_apply,
    rw ← pseudo_apply.rename name.extend F G,
    from ν_parallel₁ M
  },
  case equiv.ν_drop : Γ b y M F {
    unfold pseudo_apply,
    rw ← pseudo_apply.rename name.extend F G,
    from ν_drop₁ M
  },
  case equiv.ν_swap : Γ b y M N F {
    unfold pseudo_apply,
    calc  (ν(M) ν(N) pseudo_apply F (rename name.extend (rename name.extend G)))
        ≈ (ν(M) ν(N) pseudo_apply F (rename (name.extend ∘ name.extend) G))
          : by rw rename_compose
    ... ≈ (ν(N) ν(M) pseudo_apply (rename name.swap F) (rename name.swap (rename (name.extend ∘ name.extend) G)))
          : by { rw ← pseudo_apply.rename, from ν_swap₁ M N }
    ... ≈ (ν(N) ν(M) pseudo_apply (rename name.swap F) (rename (name.swap ∘ name.extend ∘ name.extend) G))
          : by rw rename_compose
    ... ≈ (ν(N) ν(M) pseudo_apply (rename name.swap F) (rename (name.extend ∘ name.extend) G))
          : by rw [← function.comp.assoc, name.swap_comp_extend, name.ext_extend]
    ... ≈ (ν(N) ν(M) pseudo_apply (rename name.swap F) (rename name.extend (rename name.extend G)))
          : by rw rename_compose
  },
  case equiv.apply_parallel : Γ b y bs A B {
    unfold pseudo_apply,
    from pseudo_apply_app.par bs A B G
  }
end

theorem pseudo_apply.equiv {a b} :
  ∀ {Γ} {F F' : concretion ℍ ω Γ a b} {G G' : concretion ℍ ω Γ b a}
  , F ≈ F' → G ≈ G' → pseudo_apply F G ≈ pseudo_apply F' G'
| Γ F F' G G' eq_1 eq_2 :=
  calc  pseudo_apply F  G
      ≈ pseudo_apply F' G  : pseudo_apply.equiv_l eq_1
  ... ≈ pseudo_apply G  F' : pseudo_apply.symm F' G
  ... ≈ pseudo_apply G' F' : pseudo_apply.equiv_l eq_2
  ... ≈ pseudo_apply F' G' : pseudo_apply.symm G' F'

protected lemma pseudo_apply.on_parallel₂'
    {Γ} {a b} (A : species ℍ ω Γ) (F : concretion ℍ ω Γ a b) (G : concretion ℍ ω Γ b a)
  : pseudo_apply (A |₂ F) G ≈ (A |ₛ pseudo_apply F G) :=
  calc  pseudo_apply (A |₂ F) G
      ≈ pseudo_apply G (A |₂ F) : pseudo_apply.symm _ G
  ... ≈ (A |ₛ pseudo_apply G F) : pseudo_apply.on_parallel₂ G A F
  ... ≈ (A |ₛ pseudo_apply F G) : ξ_parallel₂ (pseudo_apply.symm G F)

protected lemma pseudo_apply.parallel_shift
    {Γ} {a b} (F : concretion ℍ ω Γ a b) (A : species ℍ ω Γ) (G : concretion ℍ ω Γ b a)
  : pseudo_apply (F |₁ A) G ≈ pseudo_apply F (A |₂ G) :=
  calc  pseudo_apply (F |₁ A) G
      ≈ pseudo_apply G (F |₁ A) : pseudo_apply.symm _ G
  ... ≈ (pseudo_apply G F |ₛ A) : pseudo_apply.on_parallel₁ G F A
  ... ≈ (A |ₛ pseudo_apply G F) : parallel_symm
  ... ≈ (A |ₛ pseudo_apply F G) : ξ_parallel₂ (pseudo_apply.symm G F)
  ... ≈ pseudo_apply F (A |₂ G) : symm (pseudo_apply.on_parallel₂ F A G)

/-- Pseudo application lifted to the level of quotients. -/
def pseudo_apply.quotient {Γ a b}
  : concretion' ℍ ω Γ a b → concretion' ℍ ω Γ b a
  → species' ℍ ω Γ
| F G := quotient.lift_on₂ F G
  (λ F G, ⟦ pseudo_apply F G ⟧)
  (λ F G F' G' eqF eqG, quot.sound (pseudo_apply.equiv eqF eqG))

lemma pseudo_apply.quotient.symm {Γ a b} :
  ∀ (F : concretion' ℍ ω Γ a b) (G : concretion' ℍ ω Γ b a)
  , pseudo_apply.quotient F G = pseudo_apply.quotient G F
| F G := begin
  rcases quot.exists_rep F with ⟨ F, ⟨ _ ⟩ ⟩,
  rcases quot.exists_rep G with ⟨ G, ⟨ _ ⟩ ⟩,

  show ⟦pseudo_apply F G⟧ = ⟦pseudo_apply G F⟧,
  from quot.sound (pseudo_apply.symm F G),
end

end concretion
end cpi

#lint-


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.sheaves.sheaf
import Mathlib.category_theory.limits.preserves.shapes.products
import Mathlib.category_theory.limits.types
import Mathlib.PostPort

universes u₁ v u₂

namespace Mathlib

/-!
# Checking the sheaf condition on the underlying presheaf of types.

If `G : C ⥤ D` is a functor which reflects isomorphisms and preserves limits
(we assume all limits exist in both `C` and `D`),
then checking the sheaf condition for a presheaf `F : presheaf C X`
is equivalent to checking the sheaf condition for `F ⋙ G`.

The important special case is when
`C` is a concrete category with a forgetful functor
that preserves limits and reflects isomorphisms.
Then to check the sheaf condition it suffices
to check it on the underlying sheaf of types.

## References
* https://stacks.math.columbia.edu/tag/0073
-/

namespace Top

namespace presheaf

namespace sheaf_condition

/--
When `G` preserves limits, the sheaf condition diagram for `F` composed with `G` is
naturally isomorphic to the sheaf condition diagram for `F ⋙ G`.
-/
def diagram_comp_preserves_limits {C : Type u₁} [category_theory.category C] [category_theory.limits.has_limits C] {D : Type u₂} [category_theory.category D] [category_theory.limits.has_limits D] (G : C ⥤ D) [category_theory.limits.preserves_limits G] {X : Top} (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) : sheaf_condition_equalizer_products.diagram F U ⋙ G ≅ sheaf_condition_equalizer_products.diagram (F ⋙ G) U :=
  category_theory.nat_iso.of_components
    (fun (X_1 : category_theory.limits.walking_parallel_pair) =>
      category_theory.limits.walking_parallel_pair.cases_on X_1
        (category_theory.limits.preserves_product.iso G fun (i : ι) => category_theory.functor.obj F (opposite.op (U i)))
        (category_theory.limits.preserves_product.iso G
          fun (p : ι × ι) => category_theory.functor.obj F (opposite.op (U (prod.fst p) ⊓ U (prod.snd p)))))
    sorry

/--
When `G` preserves limits, the image under `G` of the sheaf condition fork for `F`
is the sheaf condition fork for `F ⋙ G`,
postcomposed with the inverse of the natural isomorphism `diagram_comp_preserves_limits`.
-/
def map_cone_fork {C : Type u₁} [category_theory.category C] [category_theory.limits.has_limits C] {D : Type u₂} [category_theory.category D] [category_theory.limits.has_limits D] (G : C ⥤ D) [category_theory.limits.preserves_limits G] {X : Top} (F : presheaf C X) {ι : Type v} (U : ι → topological_space.opens ↥X) : category_theory.functor.map_cone G (sheaf_condition_equalizer_products.fork F U) ≅
  category_theory.functor.obj
    (category_theory.limits.cones.postcompose (category_theory.iso.inv (diagram_comp_preserves_limits G F U)))
    (sheaf_condition_equalizer_products.fork (F ⋙ G) U) :=
  category_theory.limits.cones.ext
    (category_theory.iso.refl
      (category_theory.limits.cone.X (category_theory.functor.map_cone G (sheaf_condition_equalizer_products.fork F U))))
    sorry

end sheaf_condition

/--
If `G : C ⥤ D` is a functor which reflects isomorphisms and preserves limits
(we assume all limits exist in both `C` and `D`),
then checking the sheaf condition for a presheaf `F : presheaf C X`
is equivalent to checking the sheaf condition for `F ⋙ G`.

The important special case is when
`C` is a concrete category with a forgetful functor
that preserves limits and reflects isomorphisms.
Then to check the sheaf condition it suffices to check it on the underlying sheaf of types.

Another useful example is the forgetful functor `TopCommRing ⥤ Top`.

See https://stacks.math.columbia.edu/tag/0073.
In fact we prove a stronger version with arbitrary complete target category.
-/
def sheaf_condition_equiv_sheaf_condition_comp {C : Type u₁} [category_theory.category C] {D : Type u₂} [category_theory.category D] (G : C ⥤ D) [category_theory.reflects_isomorphisms G] [category_theory.limits.has_limits C] [category_theory.limits.has_limits D] [category_theory.limits.preserves_limits G] {X : Top} (F : presheaf C X) : sheaf_condition F ≃ sheaf_condition (F ⋙ G) := sorry


import .pushout_lemmas

local attribute [instance] classical.prop_decidable

universe u

open category_theory set

namespace homotopy_theory.topological_spaces
open homotopy_theory.topological_spaces.Top
local notation `Top` := Top.{u}

def closed_t1_inclusion {A X : Top} (i : A ⟶ X) : Prop :=
embedding i ∧ is_closed (set.range i) ∧ ∀ x, x ∉ set.range i → is_closed ({x} : set X)

lemma closed_t1_inclusion_of_closed_embedding_t1 {A X : Top} [t1_space X] (i : A ⟶ X)
  (h₁ : embedding i) (h₂ : is_closed (set.range i)) : closed_t1_inclusion i :=
⟨h₁, h₂, λ x _, is_closed_singleton⟩

lemma closed_t1_inclusion_id {X : Top} : closed_t1_inclusion (𝟙 X) :=
⟨embedding_id, by convert is_closed_univ; exact range_id, λ x hx, false.elim (hx ⟨x, rfl⟩)⟩

lemma closed_t1_inclusion_comp {X Y Z : Top} {f : X ⟶ Y} {g : Y ⟶ Z}
  (hf : closed_t1_inclusion f) (hg : closed_t1_inclusion g) : closed_t1_inclusion (f ≫ g) :=
⟨hg.1.comp hf.1,
 by convert embedding_is_closed hg.1 hg.2.1 hf.2.1; apply range_comp,
 λ z hz, if hz' : z ∈ range g
   then let ⟨y, hy⟩ := hz' in
     have y ∉ range f, from λ hy', hz (by erw range_comp; exact ⟨y, hy', hy⟩),
     by convert embedding_is_closed hg.1 hg.2.1 (hf.2.2 y this); rw ←hy; simp
   else hg.2.2 z hz'⟩

section
parameters {A B X Y : Top} {i : A ⟶ X} {f : A ⟶ B} {g : X ⟶ Y} {j : B ⟶ Y}
parameter (po : Is_pushout i f g j)
include po

lemma closed_t1_inclusion_of_pushout (h : closed_t1_inclusion i) : closed_t1_inclusion j :=
⟨embedding_j_of_embedding_i po h.1,
 (range_i_closed_iff_range_j_closed po).mp h.2.1,
 λ y hy, begin
   rw is_closed_in_pushout po, split,
   { let g' := complement_homeomorphism po (or.inl h.2.1),
     let x := g'.inv ⟨y, hy⟩,
     suffices : g ⁻¹' {y} = {x.val},
     { rw this, apply h.2.2 x.val x.property },
     have g'x : g'.hom x = ⟨y, hy⟩,
     { ext,
       change (g'.inv ≫ g'.hom ≫ incl _) ⟨y, hy⟩ = y,
       simp, refl },
     suffices : ∀ x', g x' = y → x' = x.val,
     { ext x',
       rw [mem_preimage, mem_singleton_iff, mem_singleton_iff],
       refine ⟨this x', _⟩,
       rintro rfl,
       convert Top.hom_congr (complement_homeomorphism_eq po (or.inl h.2.1)).symm x,
       exact congr_arg subtype.val g'x.symm },
     intros x' hx',
     have : x' ∉ range i,
     { rintro ⟨a, rfl⟩,
       change (i ≫ g) a = y at hx',
       rw po.commutes at hx',
       exact hy ⟨f a, hx'⟩ },
     have : g'.hom ⟨x', this⟩ = ⟨y, hy⟩,
     { ext,
       convert ←Top.hom_congr (complement_homeomorphism_eq po (or.inl h.2.1)).symm ⟨x', this⟩ },
     have : g'.hom ⟨x', _⟩ = g'.hom x, from this.trans g'x.symm,
     exact congr_arg subtype.val ((homeomorphism.embedding g').inj this) },
   { convert is_closed_empty,
     rw ←preimage_inter_range,
     convert preimage_empty,
     -- FIXME: Used to be `rwa singleton_inter_eq_empty`
     exact singleton_inter_eq_empty.mpr hy }
 end⟩

end

end homotopy_theory.topological_spaces


import algebra.homology.homological_complex
import algebra.homology.additive

open category_theory
open category_theory.category
open category_theory.preadditive

variables {C : Type*} [category C] [preadditive C]
variables {ι : Type*} {c : complex_shape ι}

namespace homological_complex
/-
@[simp]
def eq_to_hom_f {K L : homological_complex C c} (h : K = L) (n : ι) :
  homological_complex.hom.f (eq_to_hom h) n =
  eq_to_hom (congr_fun (congr_arg homological_complex.X h) n) :=
by { subst h, simp only [homological_complex.id_f, eq_to_hom_refl], }

@[ext]
def ext {K L : homological_complex C c} (h_X : K.X = L.X)
  (h_d : ∀ (i j : ι), c.rel i j → K.d i j ≫ eq_to_hom (congr_fun h_X j) =
    eq_to_hom (congr_fun h_X i) ≫ L.d i j) : K = L :=
begin
  cases K,
  cases L,
  dsimp at h_X,
  subst h_X,
  simp only [true_and, eq_self_iff_true, heq_iff_eq],
  ext i j,
  by_cases hij : c.rel i j,
  { simpa only [id_comp, eq_to_hom_refl, comp_id] using h_d i j hij, },
  { rw [K_shape' i j hij, L_shape' i j hij], }
end-/

def congr_X {K L : homological_complex C c} (h : K = L) :
  ∀ (n : ι), K.X n = L.X n :=
by { intro n, subst h, }

def congr_d {K L : homological_complex C c} (h : K = L) :
  ∀ (i j : ι), c.rel i j → K.d i j ≫ eq_to_hom (congr_X h j) =
  eq_to_hom (congr_X h i) ≫ L.d i j:=
by { intros i j hij, subst h, simp only [id_comp, eq_to_hom_refl, comp_id], }

end homological_complex

namespace chain_complex

variables {D : Type*} [category D] [preadditive D]
variables {α : Type*} [add_right_cancel_semigroup α] [has_one α] [decidable_eq α]

lemma map_of (F : C ⥤ D) [F.additive] (X : α → C) (d : Π n, X (n+1) ⟶ X n)
  (sq : ∀ n, d (n+1) ≫ d n = 0) :
  (F.map_homological_complex _).obj (chain_complex.of X d sq) =
  chain_complex.of (λ n, F.obj (X n))
    (λ n, F.map (d n)) (λ n, by rw [ ← F.map_comp, sq n, functor.map_zero]) :=
begin
  apply homological_complex.ext,
  intros i j hij,
  { have h : j+1=i := hij,
    subst h,
    simp only [of_d, functor.map_homological_complex_obj_d, id_comp,
      eq_to_hom_refl, comp_id], },
  { refl, }
end

end chain_complex

namespace homological_complex

lemma is_iso_of_components {A B : homological_complex C c} (f : A ⟶ B)
  [∀ (n : ι), is_iso (f.f n)] : is_iso f :=
begin
  convert is_iso.of_iso (homological_complex.hom.iso_of_components (λ n, as_iso (f.f n))
    (by tidy)),
  ext n,
  refl,
end

instance {D : Type*} [category D] [preadditive D]
  {F : C ⥤ D} [F.additive] [full F] [faithful F] :
  reflects_isomorphisms (functor.map_homological_complex F c) :=
⟨λ A B f, begin
  introI,
  suffices : ∀ (n : ι), is_iso (f.f n),
  { haveI := this, apply is_iso_of_components, },
  intro n,
  apply is_iso_of_reflects_iso _ F,
  change is_iso ((homological_complex.eval D c n).map ((F.map_homological_complex c).map f)),
  apply_instance,
end⟩

end homological_complex


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

An experimental variant on the `ring` tactic that uses computational
reflection instead of proof generation. Useful for kernel benchmarking.
-/
import tactic.ring data.num.lemmas

namespace tactic.ring2

@[derive has_reflect]
inductive {u} tree (α : Type u) : Type u
| nil {} : tree
| node : α → tree → tree → tree

def tree.get {α} [has_zero α] : pos_num → tree α → α
| _                tree.nil            := 0
| pos_num.one      (tree.node a t₁ t₂) := a
| (pos_num.bit0 n) (tree.node a t₁ t₂) := t₁.get n
| (pos_num.bit1 n) (tree.node a t₁ t₂) := t₂.get n

def tree.of_rbnode {α} : rbnode α → tree α
| rbnode.leaf               := tree.nil
| (rbnode.red_node l a r)   :=
  tree.node a (tree.of_rbnode l) (tree.of_rbnode r)
| (rbnode.black_node l a r) :=
  tree.node a (tree.of_rbnode l) (tree.of_rbnode r)

def tree.index_of {α} (lt : α → α → Prop) [decidable_rel lt]
  (x : α) : tree α → option pos_num
| tree.nil := none
| (tree.node a t₁ t₂) :=
  match cmp_using lt x a with
  | ordering.lt := pos_num.bit0 <$> tree.index_of t₁
  | ordering.eq := some pos_num.one
  | ordering.gt := pos_num.bit1 <$> tree.index_of t₂
  end

meta def tree.reflect' (u : level) (α : expr) : tree expr → expr
| tree.nil := (expr.const ``tree.nil [u] : expr) α
| (tree.node a t₁ t₂) :=
  (expr.const ``tree.node [u] : expr) α a t₁.reflect' t₂.reflect'

@[derive has_reflect]
inductive csring_expr
| atom : pos_num → csring_expr
| const : num → csring_expr
| add : csring_expr → csring_expr → csring_expr
| mul : csring_expr → csring_expr → csring_expr
| pow : csring_expr → num → csring_expr

namespace csring_expr

def eval {α} [comm_semiring α] (t : tree α) : csring_expr → α
| (atom n)  := @tree.get _ ⟨0⟩ n t
| (const n) := n
| (add x y) := eval x + eval y
| (mul x y) := eval x * eval y
| (pow x n) := eval x ^ (n : ℕ)

end csring_expr

@[derive decidable_eq]
inductive horner_expr
| const : znum → horner_expr
| horner : horner_expr → pos_num → num → horner_expr → horner_expr

namespace horner_expr

def is_cs : horner_expr → Prop
| (const n) := ∃ m:num, n = m.to_znum
| (horner a x n b) := is_cs a ∧ is_cs b

instance : has_zero horner_expr := ⟨const 0⟩
instance : has_one horner_expr := ⟨const 1⟩

def atom (n : pos_num) : horner_expr := horner 1 n 1 0

def repr : horner_expr → string
| (const n) := _root_.repr n
| (horner a x n b) :=
    "(" ++ repr a ++ ") * x" ++ _root_.repr x ++ "^"
        ++ _root_.repr n ++ " + " ++ repr b
instance : has_repr horner_expr := ⟨repr⟩

def horner' (a : horner_expr)
  (x : pos_num) (n : num) (b : horner_expr) : horner_expr :=
match a with
| const q := if q = 0 then b else horner a x n b
| horner a₁ x₁ n₁ b₁ :=
  if x₁ = x ∧ b₁ = 0 then horner a₁ x (n₁ + n) b
  else horner a x n b
end

def add_const (k : znum) (e : horner_expr) : horner_expr :=
if k = 0 then e else begin
  induction e with n a x n b A B,
  { exact const (k + n) },
  { exact horner a x n B }
end

def add_aux (a₁ : horner_expr) (A₁ : horner_expr → horner_expr) (x₁ : pos_num) :
  horner_expr → num → horner_expr → (horner_expr → horner_expr) → horner_expr
| (const n₂)           n₁ b₁ B₁ := add_const n₂ (horner a₁ x₁ n₁ b₁)
| (horner a₂ x₂ n₂ b₂) n₁ b₁ B₁ :=
  let e₂ := horner a₂ x₂ n₂ b₂ in
  match pos_num.cmp x₁ x₂ with
  | ordering.lt := horner a₁ x₁ n₁ (B₁ e₂)
  | ordering.gt := horner a₂ x₂ n₂ (add_aux b₂ n₁ b₁ B₁)
  | ordering.eq :=
    match num.sub' n₁ n₂ with
    | znum.zero := horner' (A₁ a₂) x₁ n₁ (B₁ b₂)
    | (znum.pos k) := horner (add_aux a₂ k 0 id) x₁ n₂ (B₁ b₂)
    | (znum.neg k) := horner (A₁ (horner a₂ x₁ k 0)) x₁ n₁ (B₁ b₂)
    end
  end

def add : horner_expr → horner_expr → horner_expr
| (const n₁)           e₂ := add_const n₁ e₂
| (horner a₁ x₁ n₁ b₁) e₂ := add_aux a₁ (add a₁) x₁ e₂ n₁ b₁ (add b₁)
/-begin
  induction e₁ with n₁ a₁ x₁ n₁ b₁ A₁ B₁ generalizing e₂,
  { exact add_const n₁ e₂ },
  exact match e₂ with e₂ := begin
    induction e₂ with n₂ a₂ x₂ n₂ b₂ A₂ B₂ generalizing n₁ b₁;
    let e₁ := horner a₁ x₁ n₁ b₁,
    { exact add_const n₂ e₁ },
    let e₂ := horner a₂ x₂ n₂ b₂,
    exact match pos_num.cmp x₁ x₂ with
    | ordering.lt := horner a₁ x₁ n₁ (B₁ e₂)
    | ordering.gt := horner a₂ x₂ n₂ (B₂ n₁ b₁)
    | ordering.eq :=
      match num.sub' n₁ n₂ with
      | znum.zero := horner' (A₁ a₂) x₁ n₁ (B₁ b₂)
      | (znum.pos k) := horner (A₂ k 0) x₁ n₂ (B₁ b₂)
      | (znum.neg k) := horner (A₁ (horner a₂ x₁ k 0)) x₁ n₁ (B₁ b₂)
      end
    end
  end end
end-/

def neg (e : horner_expr) : horner_expr :=
begin
  induction e with n a x n b A B,
  { exact const (-n) },
  { exact horner A x n B }
end

def mul_const (k : znum) (e : horner_expr) : horner_expr :=
if k = 0 then 0 else if k = 1 then e else begin
  induction e with n a x n b A B,
  { exact const (n * k) },
  { exact horner A x n B }
end

def mul_aux (a₁ x₁ n₁ b₁) (A₁ B₁ : horner_expr → horner_expr) :
  horner_expr → horner_expr
| (const n₂) := mul_const n₂ (horner a₁ x₁ n₁ b₁)
| e₂@(horner a₂ x₂ n₂ b₂) :=
  match pos_num.cmp x₁ x₂ with
  | ordering.lt := horner (A₁ e₂) x₁ n₁ (B₁ e₂)
  | ordering.gt := horner (mul_aux a₂) x₂ n₂ (mul_aux b₂)
  | ordering.eq := let haa := horner' (mul_aux a₂) x₁ n₂ 0 in
    if b₂ = 0 then haa else haa.add (horner (A₁ b₂) x₁ n₁ (B₁ b₂))
  end

def mul : horner_expr → horner_expr → horner_expr
| (const n₁)              := mul_const n₁
| e₁@(horner a₁ x₁ n₁ b₁) := mul_aux a₁ x₁ n₁ b₁ (mul a₁) (mul b₁).
/-begin
  induction e₁ with n₁ a₁ x₁ n₁ b₁ A₁ B₁ generalizing e₂,
  { exact mul_const n₁ e₂ },
  induction e₂ with n₂ a₂ x₂ n₂ b₂ A₂ B₂;
  let e₁ := horner a₁ x₁ n₁ b₁,
  { exact mul_const n₂ e₁ },
  let e₂ := horner a₂ x₂ n₂ b₂,
  cases pos_num.cmp x₁ x₂,
  { exact horner (A₁ e₂) x₁ n₁ (B₁ e₂) },
  { let haa := horner' A₂ x₁ n₂ 0,
    exact if b₂ = 0 then haa else
      haa.add (horner (A₁ b₂) x₁ n₁ (B₁ b₂)) },
  { exact horner A₂ x₂ n₂ B₂ }
end-/

instance : has_add horner_expr := ⟨add⟩
instance : has_neg horner_expr := ⟨neg⟩
instance : has_mul horner_expr := ⟨mul⟩

def pow (e : horner_expr) : num → horner_expr
| 0 := 1
| (num.pos p) := begin
  induction p with p ep p ep,
  { exact e },
  { exact (ep.mul ep).mul e },
  { exact ep.mul ep }
end

def inv (e : horner_expr) : horner_expr := 0

def of_csexpr : csring_expr → horner_expr
| (csring_expr.atom n)  := atom n
| (csring_expr.const n) := const n.to_znum
| (csring_expr.add x y) := (of_csexpr x).add (of_csexpr y)
| (csring_expr.mul x y) := (of_csexpr x).mul (of_csexpr y)
| (csring_expr.pow x n) := (of_csexpr x).pow n

def cseval {α} [comm_semiring α] (t : tree α) : horner_expr → α
| (const n)        := n.abs
| (horner a x n b) := tactic.ring.horner (cseval a) (t.get x) n (cseval b)

theorem cseval_atom {α} [comm_semiring α] (t : tree α)
  (n : pos_num) : (atom n).is_cs ∧ cseval t (atom n) = t.get n :=
⟨⟨⟨1, rfl⟩, ⟨0, rfl⟩⟩, (tactic.ring.horner_atom _).symm⟩

theorem cseval_add_const {α} [comm_semiring α] (t : tree α)
  (k : num) {e : horner_expr} (cs : e.is_cs) :
  (add_const k.to_znum e).is_cs ∧
    cseval t (add_const k.to_znum e) = k + cseval t e :=
begin
  simp [add_const],
  cases k; simp! *,
  simp [show znum.pos k ≠ 0, from dec_trivial],
  induction e with n a x n b A B; simp *,
  { rcases cs with ⟨n, rfl⟩,
    refine ⟨⟨n + num.pos k, by simp; refl⟩, _⟩,
    cases n; simp! },
  { rcases B cs.2 with ⟨csb, h⟩, simp! [*, cs.1],
    rw [← tactic.ring.horner_add_const, add_comm], refl }
end

theorem cseval_horner' {α} [comm_semiring α] (t : tree α)
  (a x n b) (h₁ : is_cs a) (h₂ : is_cs b) :
  (horner' a x n b).is_cs ∧ cseval t (horner' a x n b) =
    tactic.ring.horner (cseval t a) (t.get x) n (cseval t b) :=
begin
  cases a with n₁ a₁ x₁ n₁ b₁; simp [horner']; split_ifs,
  { simp! [*, tactic.ring.horner] },
  { exact ⟨⟨h₁, h₂⟩, rfl⟩ },
  { refine ⟨⟨h₁.1, h₂⟩, eq.symm _⟩, simp! *,
    apply tactic.ring.horner_horner, simp },
  { exact ⟨⟨h₁, h₂⟩, rfl⟩ }
end

theorem cseval_add {α} [comm_semiring α] (t : tree α)
  {e₁ e₂ : horner_expr} (cs₁ : e₁.is_cs) (cs₂ : e₂.is_cs) :
  (add e₁ e₂).is_cs ∧
  cseval t (add e₁ e₂) = cseval t e₁ + cseval t e₂ :=
begin
  induction e₁ with n₁ a₁ x₁ n₁ b₁ A₁ B₁ generalizing e₂; simp!,
  { rcases cs₁ with ⟨n₁, rfl⟩,
    simpa using cseval_add_const t n₁ cs₂ },
  induction e₂ with n₂ a₂ x₂ n₂ b₂ A₂ B₂ generalizing n₁ b₁,
  { rcases cs₂ with ⟨n₂, rfl⟩,
    simp! [cseval_add_const t n₂ cs₁] },
  cases cs₁ with csa₁ csb₁, cases id cs₂ with csa₂ csb₂,
  simp!, have C := pos_num.cmp_to_nat x₁ x₂,
  cases pos_num.cmp x₁ x₂; simp!,
  { rcases B₁ csb₁ cs₂ with ⟨csh, h⟩,
    refine ⟨⟨csa₁, csh⟩, eq.symm _⟩,
    apply tactic.ring.horner_add_const,
    exact h.symm },
  { cases C,
    have B0 : is_cs 0 → ∀ {e₂ : horner_expr}, is_cs e₂ →
      is_cs (add 0 e₂) ∧ cseval t (add 0 e₂) = cseval t 0 + cseval t e₂ :=
      λ _ e₂ c, ⟨c, (zero_add _).symm⟩,
     cases e : num.sub' n₁ n₂ with k k; simp!,
    { have : n₁ = n₂,
      { have := congr_arg (coe : znum → ℤ) e,
        simp at this,
        have := sub_eq_zero.1 this,
        rw [← num.to_nat_to_int, ← num.to_nat_to_int] at this,
        exact num.to_nat_inj.1 (int.coe_nat_inj this) },
      subst n₂,
      rcases cseval_horner' _ _ _ _ _ _ _ with ⟨csh, h⟩,
      { refine ⟨csh, h.trans (eq.symm _)⟩,
        simp *,
        apply tactic.ring.horner_add_horner_eq; try {refl},
        simp },
      all_goals {simp! *} },
    { simp [B₁ csb₁ csb₂],
      rcases A₂ csa₂ _ _ B0 ⟨csa₁, 0, rfl⟩ with ⟨csh, h⟩,
      refine ⟨csh, eq.symm _⟩,
      rw [show id = add 0, from rfl, h],
      apply tactic.ring.horner_add_horner_gt,
      { change (_ + k : ℕ) = _,
        rw [← int.coe_nat_inj', int.coe_nat_add,
          eq_comm, ← sub_eq_iff_eq_add'],
        simpa using congr_arg (coe : znum → ℤ) e },
      all_goals { apply add_comm } },
    { have : (horner a₂ x₁ (num.pos k) 0).is_cs := ⟨csa₂, 0, rfl⟩,
      simp [B₁ csb₁ csb₂, A₁ csa₁ this],
      symmetry, apply tactic.ring.horner_add_horner_lt,
      { change (_ + k : ℕ) = _,
          rw [← int.coe_nat_inj', int.coe_nat_add,
            eq_comm, ← sub_eq_iff_eq_add', ← neg_inj', neg_sub],
        simpa using congr_arg (coe : znum → ℤ) e },
      { refl }, { apply add_comm } } },
  { rcases B₂ csb₂ _ _ B₁ ⟨csa₁, csb₁⟩ with ⟨csh, h⟩,
    refine ⟨⟨csa₂, csh⟩, eq.symm _⟩,
    apply tactic.ring.const_add_horner,
    simp [h] }
end

theorem cseval_mul_const {α} [comm_semiring α] (t : tree α)
  (k : num) {e : horner_expr} (cs : e.is_cs) :
  (mul_const k.to_znum e).is_cs ∧
    cseval t (mul_const k.to_znum e) = cseval t e * k :=
begin
  simp [mul_const],
  split_ifs with h h,
  { cases (num.to_znum_inj.1 h : k = 0),
    exact ⟨⟨0, rfl⟩, (mul_zero _).symm⟩ },
  { cases (num.to_znum_inj.1 h : k = 1),
    exact ⟨cs, (mul_one _).symm⟩ },
  induction e with n a x n b A B; simp *,
  { rcases cs with ⟨n, rfl⟩,
    suffices, refine ⟨⟨n * k, this⟩, _⟩,
    swap, {cases n; cases k; refl},
    rw [show _, from this], simp! },
  { cases cs, simp! *,
    symmetry, apply tactic.ring.horner_mul_const; refl }
end

theorem cseval_mul {α} [comm_semiring α] (t : tree α)
  {e₁ e₂ : horner_expr} (cs₁ : e₁.is_cs) (cs₂ : e₂.is_cs) :
  (mul e₁ e₂).is_cs ∧
  cseval t (mul e₁ e₂) = cseval t e₁ * cseval t e₂ :=
begin
  induction e₁ with n₁ a₁ x₁ n₁ b₁ A₁ B₁ generalizing e₂; simp!,
  { rcases cs₁ with ⟨n₁, rfl⟩,
    simpa [mul_comm] using cseval_mul_const t n₁ cs₂ },
  induction e₂ with n₂ a₂ x₂ n₂ b₂ A₂ B₂,
  { rcases cs₂ with ⟨n₂, rfl⟩,
    simpa! using cseval_mul_const t n₂ cs₁ },
  cases cs₁ with csa₁ csb₁, cases id cs₂ with csa₂ csb₂,
  simp!, have C := pos_num.cmp_to_nat x₁ x₂,
  cases A₂ csa₂ with csA₂ hA₂,
  cases pos_num.cmp x₁ x₂; simp!,
  { simp [A₁ csa₁ cs₂, B₁ csb₁ cs₂],
    symmetry, apply tactic.ring.horner_mul_const; refl },
  { cases cseval_horner' t _ x₁ n₂ 0 csA₂ ⟨0, rfl⟩ with csh₁ h₁,
    cases C, split_ifs,
    { subst b₂,
      refine ⟨csh₁, h₁.trans (eq.symm _)⟩,
      apply tactic.ring.horner_mul_horner_zero; try {refl},
      simp! [hA₂] },
    { cases A₁ csa₁ csb₂ with csA₁ hA₁,
      cases cseval_add t csh₁ _ with csh₂ h₂,
      { refine ⟨csh₂, h₂.trans (eq.symm _)⟩,
        apply tactic.ring.horner_mul_horner; try {refl},
        simp! * },
      exact ⟨csA₁, (B₁ csb₁ csb₂).1⟩ } },
  { simp [A₂ csa₂, B₂ csb₂], rw [mul_comm, eq_comm],
    apply tactic.ring.horner_const_mul,
    {apply mul_comm}, {refl} },
end

theorem cseval_pow {α} [comm_semiring α] (t : tree α)
  {x : horner_expr} (cs : x.is_cs) :
  ∀ (n : num), (pow x n).is_cs ∧
    cseval t (pow x n) = cseval t x ^ (n : ℕ)
| 0 := ⟨⟨1, rfl⟩, (pow_zero _).symm⟩
| (num.pos p) := begin
  simp [pow], induction p with p ep p ep,
  { simp * },
  { simp [pow_bit1],
    cases cseval_mul t ep.1 ep.1 with cs₀ h₀,
    cases cseval_mul t cs₀ cs with cs₁ h₁,
    simp * },
  { simp [pow_bit0],
    cases cseval_mul t ep.1 ep.1 with cs₀ h₀,
    simp * }
end

theorem cseval_of_csexpr {α} [comm_semiring α] (t : tree α) :
  ∀ (r : csring_expr), (of_csexpr r).is_cs ∧ cseval t (of_csexpr r) = r.eval t
| (csring_expr.atom n)  := cseval_atom _ _
| (csring_expr.const n) := ⟨⟨n, rfl⟩, by cases n; refl⟩
| (csring_expr.add x y) :=
  let ⟨cs₁, h₁⟩ := cseval_of_csexpr x,
      ⟨cs₂, h₂⟩ := cseval_of_csexpr y,
      ⟨cs, h⟩ := cseval_add t cs₁ cs₂ in ⟨cs, by simp! [h, *]⟩
| (csring_expr.mul x y) :=
  let ⟨cs₁, h₁⟩ := cseval_of_csexpr x,
      ⟨cs₂, h₂⟩ := cseval_of_csexpr y,
      ⟨cs, h⟩ := cseval_mul t cs₁ cs₂ in ⟨cs, by simp! [h, *]⟩
| (csring_expr.pow x n) :=
  let ⟨cs, h⟩ := cseval_of_csexpr x,
      ⟨cs, h⟩ := cseval_pow t cs n in ⟨cs, by simp! [h, *]⟩

end horner_expr

theorem correctness {α} [comm_semiring α] (t : tree α) (r₁ r₂ : csring_expr)
  (H : horner_expr.of_csexpr r₁ = horner_expr.of_csexpr r₂) :
  r₁.eval t = r₂.eval t :=
by repeat {rw ← (horner_expr.cseval_of_csexpr t _).2}; rw H

meta def reflect_expr : expr → csring_expr × dlist expr
| `(%%e₁ + %%e₂) :=
  let (r₁, l₁) := reflect_expr e₁, (r₂, l₂) := reflect_expr e₂ in
  (r₁.add r₂, l₁ ++ l₂)
/-| `(%%e₁ - %%e₂) :=
  let (r₁, l₁) := reflect_expr e₁, (r₂, l₂) := reflect_expr e₂ in
  (r₁.add r₂.neg, l₁ ++ l₂)
| `(- %%e) := let (r, l) := reflect_expr e in (r.neg, l)-/
| `(%%e₁ * %%e₂) :=
  let (r₁, l₁) := reflect_expr e₁, (r₂, l₂) := reflect_expr e₂ in
  (r₁.mul r₂, l₁ ++ l₂)
/-| `(has_inv.inv %%e) := let (r, l) := reflect_expr e in (r.neg, l)
| `(%%e₁ / %%e₂) :=
  let (r₁, l₁) := reflect_expr e₁, (r₂, l₂) := reflect_expr e₂ in
  (r₁.mul r₂.inv, l₁ ++ l₂)-/
| e@`(%%e₁ ^ %%e₂) :=
  match reflect_expr e₁, expr.to_nat e₂ with
  | (r₁, l₁), some n₂ := (r₁.pow (num.of_nat' n₂), l₁)
  | (r₁, l₁), none := (csring_expr.atom 1, dlist.singleton e)
  end
| e := match expr.to_nat e with
  | some n := (csring_expr.const (num.of_nat' n), dlist.empty)
  | none := (csring_expr.atom 1, dlist.singleton e)
  end

meta def csring_expr.replace (t : tree expr) : csring_expr → state_t (list expr) option csring_expr
| (csring_expr.atom _)  := do e ← get,
  p ← monad_lift (t.index_of (<) e.head),
  put e.tail, pure (csring_expr.atom p)
| (csring_expr.const n) := pure (csring_expr.const n)
| (csring_expr.add x y) := csring_expr.add <$> x.replace <*> y.replace
| (csring_expr.mul x y) := csring_expr.mul <$> x.replace <*> y.replace
| (csring_expr.pow x n) := (λ x, csring_expr.pow x n) <$> x.replace
--| (csring_expr.neg x)   := csring_expr.neg <$> x.replace
--| (csring_expr.inv x)   := csring_expr.inv <$> x.replace

end tactic.ring2

namespace tactic
namespace interactive
open interactive interactive.types lean.parser
open tactic.ring2

local postfix `?`:9001 := optional

/-- Tactic for solving equations in the language of rings.
  This variant on the `ring` tactic uses kernel computation instead
  of proof generation. -/
meta def ring2 : tactic unit :=
do `[repeat {rw ← nat.pow_eq_pow}],
  `(%%e₁ = %%e₂) ← target,
  α ← infer_type e₁,
  expr.sort (level.succ u) ← infer_type α,
  let (r₁, l₁) := reflect_expr e₁,
  let (r₂, l₂) := reflect_expr e₂,
  let L := (l₁ ++ l₂).to_list,
  let s := tree.of_rbnode (rbtree_of L).1,
  (r₁, L) ← (state_t.run (r₁.replace s) L : option _),
  (r₂, _) ← (state_t.run (r₂.replace s) L : option _),
  let se : expr := s.reflect' u α,
  let er₁ : expr := reflect r₁,
  let er₂ : expr := reflect r₂,
  cs ← mk_app ``comm_semiring [α] >>= mk_instance,
  e ← to_expr ```(correctness %%se %%er₁ %%er₂ rfl)
    <|> fail ("ring2 tactic failed, using abstract equality:\n"
      ++ repr (horner_expr.of_csexpr r₁) ++
      "\n  =?=\n" ++ repr (horner_expr.of_csexpr r₂)),
  tactic.exact e

end interactive
end tactic


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

/-!
# Monoidal natural transformations

Natural transformations between (lax) monoidal functors must satisfy
an additional compatibility relation with the tensorators:
`F.μ X Y ≫ app (X ⊗ Y) = (app X ⊗ app Y) ≫ G.μ X Y`.

(Lax) monoidal functors between a fixed pair of monoidal categories
themselves form a category.
-/

open category_theory

universes v₁ v₂ v₃ u₁ u₂ u₃

open category_theory.category
open category_theory.functor

namespace category_theory

open monoidal_category

variables {C : Type u₁} [category.{v₁} C] [monoidal_category.{v₁} C]
          {D : Type u₂} [category.{v₂} D] [monoidal_category.{v₂} D]

/--
A monoidal natural transformation is a natural transformation between (lax) monoidal functors
additionally satisfying:
`F.μ X Y ≫ app (X ⊗ Y) = (app X ⊗ app Y) ≫ G.μ X Y`
-/
@[ext]
structure monoidal_nat_trans (F G : lax_monoidal_functor C D)
  extends nat_trans F.to_functor G.to_functor :=
(unit' : F.ε ≫ app (𝟙_ C) = G.ε . obviously)
(tensor' : ∀ X Y, F.μ _ _ ≫ app (X ⊗ Y) = (app X ⊗ app Y) ≫ G.μ _ _ . obviously)

restate_axiom monoidal_nat_trans.tensor'
attribute [simp, reassoc] monoidal_nat_trans.tensor
restate_axiom monoidal_nat_trans.unit'
attribute [simp, reassoc] monoidal_nat_trans.unit

namespace monoidal_nat_trans

/--
The identity monoidal natural transformation.
-/
@[simps]
def id (F : lax_monoidal_functor C D) : monoidal_nat_trans F F :=
{ ..(𝟙 F.to_functor) }

instance (F : lax_monoidal_functor C D) : inhabited (monoidal_nat_trans F F) := ⟨id F⟩

/--
Vertical composition of monoidal natural transformations.
-/
@[simps]
def vcomp {F G H : lax_monoidal_functor C D}
  (α : monoidal_nat_trans F G) (β : monoidal_nat_trans G H) : monoidal_nat_trans F H :=
{ ..(nat_trans.vcomp α.to_nat_trans β.to_nat_trans) }

instance category_lax_monoidal_functor : category (lax_monoidal_functor C D) :=
{ hom := monoidal_nat_trans,
  id := id,
  comp := λ F G H α β, vcomp α β, }

@[simp] lemma comp_to_nat_trans' {F G H : lax_monoidal_functor C D} {α : F ⟶ G} {β : G ⟶ H} :
  (α ≫ β).to_nat_trans =
    @category_struct.comp (C ⥤ D) _ _ _ _ (α.to_nat_trans) (β.to_nat_trans) := rfl

instance category_monoidal_functor : category (monoidal_functor C D) :=
induced_category.category monoidal_functor.to_lax_monoidal_functor

@[simp] lemma comp_to_nat_trans'' {F G H : monoidal_functor C D} {α : F ⟶ G} {β : G ⟶ H} :
  (α ≫ β).to_nat_trans =
    @category_struct.comp (C ⥤ D) _ _ _ _ (α.to_nat_trans) (β.to_nat_trans) := rfl

variables {E : Type u₃} [category.{v₃} E] [monoidal_category.{v₃} E]

/--
Horizontal composition of monoidal natural transformations.
-/
@[simps]
def hcomp {F G : lax_monoidal_functor C D} {H K : lax_monoidal_functor D E}
  (α : monoidal_nat_trans F G) (β : monoidal_nat_trans H K) :
  monoidal_nat_trans (F ⊗⋙ H) (G ⊗⋙ K) :=
{ unit' :=
  begin
    dsimp, simp,
    conv_lhs { rw [←K.to_functor.map_comp, α.unit], },
  end,
  tensor' := λ X Y,
  begin
    dsimp, simp,
    conv_lhs { rw [←K.to_functor.map_comp, α.tensor, K.to_functor.map_comp], },
  end,
  ..(nat_trans.hcomp α.to_nat_trans β.to_nat_trans) }

end monoidal_nat_trans

namespace monoidal_nat_iso

variables {F G : lax_monoidal_functor C D}

/--
Construct a monoidal natural isomorphism from object level isomorphisms,
and the monoidal naturality in the forward direction.
-/
def of_components
  (app : ∀ X : C, F.obj X ≅ G.obj X)
  (naturality : ∀ {X Y : C} (f : X ⟶ Y), F.map f ≫ (app Y).hom = (app X).hom ≫ G.map f)
  (unit : F.ε ≫ (app (𝟙_ C)).hom = G.ε)
  (tensor : ∀ X Y, F.μ X Y ≫ (app (X ⊗ Y)).hom = ((app X).hom ⊗ (app Y).hom) ≫ G.μ X Y) :
  F ≅ G :=
{ hom := { app := λ X, (app X).hom, },
  inv :=
  { app := λ X, (app X).inv,
    unit' := by { dsimp, rw [←unit, assoc, iso.hom_inv_id, comp_id], },
    tensor' := λ X Y,
    begin
      dsimp,
      rw [iso.comp_inv_eq, assoc, tensor, ←tensor_comp_assoc,
        iso.inv_hom_id, iso.inv_hom_id, tensor_id, id_comp],
    end,
    ..(nat_iso.of_components app @naturality).inv, }, }

@[simp] lemma of_components.hom_app
  (app : ∀ X : C, F.obj X ≅ G.obj X) (naturality) (unit) (tensor) (X) :
  (of_components app naturality unit tensor).hom.app X = (app X).hom := rfl
@[simp] lemma of_components.inv_app
  (app : ∀ X : C, F.obj X ≅ G.obj X) (naturality) (unit) (tensor) (X) :
  (of_components app naturality unit tensor).inv.app X = (app X).inv :=
by simp [of_components]

instance is_iso_of_is_iso_app (α : F ⟶ G) [∀ X : C, is_iso (α.app X)] : is_iso α :=
⟨(is_iso.of_iso (of_components (λ X, as_iso (α.app X))
  (λ X Y f, α.to_nat_trans.naturality f) α.unit α.tensor)).1⟩

end monoidal_nat_iso

end category_theory


import homotopy_theory.formal.i_category.homotopy_equivalences
import .pi_n

open function

noncomputable theory

open category_theory (hiding is_iso)
local notation f ` ∘ `:80 g:80 := g ≫ f

namespace homotopy_theory.topological_spaces
open homotopy_theory.cofibrations
open homotopy_theory.weak_equivalences
open homotopy_theory.topological_spaces.Top
local notation `Top` := Top.{0}
local notation `Set` := Type 0

def is_weak_equivalence {X Y : Top} (f : X ⟶ Y) : Prop :=
is_iso (π₀ &> f) ∧ ∀ n x, is_iso (π_induced n x f)

lemma is_weak_equivalence_iso {X Y : Top} (i : homeomorphism X Y) :
  is_weak_equivalence i.hom :=
⟨⟨π₀.map_iso i, rfl⟩,
 assume n x, ⟨(π n).map_iso (Top_ptd.mk_iso' i x), rfl⟩⟩

lemma is_weak_equivalence_comp {X Y Z : Top} {f : X ⟶ Y} {g : Y ⟶ Z}
  (hf : is_weak_equivalence f) (hg : is_weak_equivalence g) :
  is_weak_equivalence (g ∘ f) :=
⟨by rw π₀.map_comp; exact iso_comp hf.1 hg.1,
 assume n x, by rw π_induced_comp; exact iso_comp (hf.2 n x) (hg.2 n (f x))⟩

instance : replete_wide_subcategory.{0} Top @is_weak_equivalence :=
replete_wide_subcategory.mk' @is_weak_equivalence_iso @is_weak_equivalence_comp

-- I don't know why this changed, but `⟦Top.const y⟧` in the proof below
-- started using `subtype.setoid` and `fun_setoid` (from core) by default.
local attribute [instance, priority 1000] Hom.setoid

-- I don't know what this means, but lean told me to turn it on
set_option eqn_compiler.zeta true
def Top_weak_equivalences : category_with_weak_equivalences Top :=
{ is_weq := @is_weak_equivalence,
  weq_of_comp_weq_left := assume X Y Z f g hf hgf,
    ⟨iso_of_comp_iso_left hf.1 (by rw ←π₀.map_comp; exact hgf.1),
     assume n y,
     -- This is the nontrivial case: y may not be in the image of f.
     -- But we know that f is an isomorphism on π₀, so y is at least
     -- connected by a path to f x' for some x' : X.
       let ⟨i, hi⟩ := hf.1 in
       let x'_class := i.inv ⟦Top.const y⟧ in
       let ⟨x'_map, hx'⟩ := quotient.exists_rep x'_class in
       let x' := x'_map punit.star in
       have (π₀ &> f) ⟦Top.const x'⟧ = ⟦Top.const y⟧, from
         have Top.const x' = x'_map, by ext p; cases p; refl,
         begin
           rw [this, ←hi, hx'], dsimp [x'_class],
           change (i.hom ∘ i.inv) _ = _,
           erw i.inv_hom_id, refl
         end,
       have ⟦Top.const (f x')⟧ = ⟦Top.const y⟧, from this,
       let ⟨(γ : path (f x') y)⟩ := quotient.exact this in
       have is_iso (π_induced n (f x') g), from
         iso_of_comp_iso_left (hf.2 n x')
           (by rw ←π_induced_comp; exact hgf.2 n x'),
       let ⟨i', hi'⟩ := this in
       ⟨(change_of_basepoint n γ).symm.trans $
        i'.trans (change_of_basepoint n (γ.induced g)),
        show (change_of_basepoint n (γ.induced g)).hom ∘
            i'.hom ∘ (change_of_basepoint n γ).inv =
          π_induced n y g,
        by rw [hi', ←change_of_basepoint_induced, iso.inv_hom_id_assoc]⟩⟩,
  weq_of_comp_weq_right := assume X Y Z f g hg hgf,
    ⟨iso_of_comp_iso_right hg.1 (by rw ←π₀.map_comp; exact hgf.1),
     assume n x, iso_of_comp_iso_right (hg.2 n (f x))
       (by rw ←π_induced_comp; exact hgf.2 n x)⟩ }

lemma is_weak_equivalence_of_heq {X Y : Top} (f : X ⟶ Y)
  (h : homotopy_equivalence f) : is_weak_equivalence f :=
let ⟨g, gf1, fg1⟩ := homotopy_equivalence_iff.mp h in
⟨⟨⟨π₀ &> f, π₀ &> g,
   by rw [←π₀.map_comp, ←π₀.map_id]; exact π₀_induced_homotopic gf1,
   by rw [←π₀.map_comp, ←π₀.map_id]; exact π₀_induced_homotopic fg1⟩,
  rfl⟩,
 assume n x,
   have gf : _ := π_induced_homotopic_id n x gf1.symm,
   have fg : _ := π_induced_homotopic_id n (f x) fg1.symm,
   begin
     rw π_induced_comp at gf fg,
     letI : homotopical_category Set := isomorphisms_as_homotopical_category,
     change is_weq (π_induced n x f),
     exact weq_two_out_of_six_f fg gf
   end⟩

end homotopy_theory.topological_spaces


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Patrick Massot, Eric Wieser
-/
import algebra.group.prod
import group_theory.group_action.defs

/-!
# Prod instances for additive and multiplicative actions

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

This file defines instances for binary product of additive and multiplicative actions and provides
scalar multiplication as a homomorphism from `α × β` to `β`.

## Main declarations

* `smul_mul_hom`/`smul_monoid_hom`: Scalar multiplication bundled as a multiplicative/monoid
  homomorphism.

## See also

* `group_theory.group_action.option`
* `group_theory.group_action.pi`
* `group_theory.group_action.sigma`
* `group_theory.group_action.sum`
-/

variables {M N P E α β : Type*}

namespace prod

section

variables [has_smul M α] [has_smul M β] [has_smul N α] [has_smul N β] (a : M) (x : α × β)

@[to_additive prod.has_vadd] instance : has_smul M (α × β) := ⟨λa p, (a • p.1, a • p.2)⟩

@[simp, to_additive] theorem smul_fst : (a • x).1 = a • x.1 := rfl
@[simp, to_additive] theorem smul_snd : (a • x).2 = a • x.2 := rfl
@[simp, to_additive] theorem smul_mk (a : M) (b : α) (c : β) : a • (b, c) = (a • b, a • c) := rfl
@[to_additive] theorem smul_def (a : M) (x : α × β) : a • x = (a • x.1, a • x.2) := rfl
@[simp, to_additive] theorem smul_swap : (a • x).swap = a • x.swap := rfl

lemma smul_zero_mk {α : Type*} [monoid M] [add_monoid α] [distrib_mul_action M α] (a : M) (c : β) :
  a • ((0 : α), c) = (0, a • c) :=
by rw [prod.smul_mk, smul_zero]

lemma smul_mk_zero {β : Type*} [monoid M] [add_monoid β] [distrib_mul_action M β] (a : M) (b : α) :
  a • (b, (0 : β)) = (a • b, 0) :=
by rw [prod.smul_mk, smul_zero]

variables [has_pow α E] [has_pow β E]
@[to_additive has_smul] instance has_pow : has_pow (α × β) E :=
{ pow := λ p c, (p.1 ^ c, p.2 ^ c) }
@[simp, to_additive smul_fst, to_additive_reorder 6]

@[to_additive]
instance [has_smul M N] [is_scalar_tower M N α] [is_scalar_tower M N β] :
  is_scalar_tower M N (α × β) :=
⟨λ x y z, mk.inj_iff.mpr ⟨smul_assoc _ _ _, smul_assoc _ _ _⟩⟩

@[to_additive] instance [smul_comm_class M N α] [smul_comm_class M N β] :
  smul_comm_class M N (α × β) :=
{ smul_comm := λ r s x, mk.inj_iff.mpr ⟨smul_comm _ _ _, smul_comm _ _ _⟩ }

@[to_additive]
instance [has_smul Mᵐᵒᵖ α] [has_smul Mᵐᵒᵖ β] [is_central_scalar M α] [is_central_scalar M β] :
  is_central_scalar M (α × β) :=
⟨λ r m, prod.ext (op_smul_eq_smul _ _) (op_smul_eq_smul _ _)⟩

@[to_additive]
instance has_faithful_smul_left [has_faithful_smul M α] [nonempty β] :
  has_faithful_smul M (α × β) :=
⟨λ x y h, let ⟨b⟩ := ‹nonempty β› in eq_of_smul_eq_smul $ λ a : α, by injection h (a, b)⟩

@[to_additive]
instance has_faithful_smul_right [nonempty α] [has_faithful_smul M β] :
  has_faithful_smul M (α × β) :=
⟨λ x y h, let ⟨a⟩ := ‹nonempty α› in eq_of_smul_eq_smul $ λ b : β, by injection h (a, b)⟩

end

@[to_additive]
instance smul_comm_class_both [has_mul N] [has_mul P] [has_smul M N] [has_smul M P]
  [smul_comm_class M N N] [smul_comm_class M P P] :
  smul_comm_class M (N × P) (N × P) :=
⟨λ c x y, by simp [smul_def, mul_def, mul_smul_comm]⟩

instance is_scalar_tower_both [has_mul N] [has_mul P] [has_smul M N] [has_smul M P]
  [is_scalar_tower M N N] [is_scalar_tower M P P] :
  is_scalar_tower M (N × P) (N × P) :=
⟨λ c x y, by simp [smul_def, mul_def, smul_mul_assoc]⟩

@[to_additive] instance {m : monoid M} [mul_action M α] [mul_action M β] : mul_action M (α × β) :=
{ mul_smul  := λ a₁ a₂ p, mk.inj_iff.mpr ⟨mul_smul _ _ _, mul_smul _ _ _⟩,
  one_smul  := λ ⟨b, c⟩, mk.inj_iff.mpr ⟨one_smul _ _, one_smul _ _⟩ }

instance {R M N : Type*} [has_zero M] [has_zero N]
  [smul_zero_class R M] [smul_zero_class R N] : smul_zero_class R (M × N) :=
{ smul_zero := λ a, mk.inj_iff.mpr ⟨smul_zero _, smul_zero _⟩ }

instance {R M N : Type*} [add_zero_class M] [add_zero_class N]
  [distrib_smul R M] [distrib_smul R N] : distrib_smul R (M × N) :=
{ smul_add  := λ a p₁ p₂, mk.inj_iff.mpr ⟨smul_add _ _ _, smul_add _ _ _⟩ }

instance {R M N : Type*} {r : monoid R} [add_monoid M] [add_monoid N]
  [distrib_mul_action R M] [distrib_mul_action R N] : distrib_mul_action R (M × N) :=
{ ..prod.distrib_smul }

instance {R M N : Type*} {r : monoid R} [monoid M] [monoid N]
  [mul_distrib_mul_action R M] [mul_distrib_mul_action R N] : mul_distrib_mul_action R (M × N) :=
{ smul_mul  := λ a p₁ p₂, mk.inj_iff.mpr ⟨smul_mul' _ _ _, smul_mul' _ _ _⟩,
  smul_one := λ a, mk.inj_iff.mpr ⟨smul_one _, smul_one _⟩ }

end prod

/-! ### Scalar multiplication as a homomorphism -/

section bundled_smul

/-- Scalar multiplication as a multiplicative homomorphism. -/
@[simps]
def smul_mul_hom [monoid α] [has_mul β] [mul_action α β] [is_scalar_tower α β β]
  [smul_comm_class α β β] :
  (α × β) →ₙ* β :=
{ to_fun := λ a, a.1 • a.2,
  map_mul' := λ a b, (smul_mul_smul _ _ _ _).symm }

/-- Scalar multiplication as a monoid homomorphism. -/
@[simps]
def smul_monoid_hom [monoid α] [mul_one_class β] [mul_action α β] [is_scalar_tower α β β]
  [smul_comm_class α β β] :
  α × β →* β :=
{ map_one' := one_smul _ _,
  .. smul_mul_hom }

end bundled_smul


/-
Copyright (c) 2020 Gabriel Ebner. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner

! This file was ported from Lean 3 source module tactic.lint.simp
! leanprover-community/mathlib commit 7b7cd0a140c51844aa4d5a7d6ea15cb5f6e1afd7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Lint.Basic

/-!
# Linter for simplification lemmas

This files defines several linters that prevent common mistakes when declaring simp lemmas:

 * `simp_nf` checks that the left-hand side of a simp lemma is not simplified by a different lemma.
 * `simp_var_head` checks that the head symbol of the left-hand side is not a variable.
 * `simp_comm` checks that commutativity lemmas are not marked as simplification lemmas.
-/

open Tactic Expr

-- failed to format: unknown constant 'term.pseudo.antiquot'
/-- `simp_lhs_rhs ty` returns the left-hand and right-hand side of a simp lemma with type `ty`. -/
    private
    unsafe
  def
    simp_lhs_rhs
    : expr → tactic ( expr × expr )
    |
      ty
      =>
      do
        let ty ← head_beta ty
          match
            ty
            with
            | q( ¬ $ ( lhs ) ) => pure ( lhs , q( False ) )
              | q( $ ( lhs ) = $ ( rhs ) ) => pure ( lhs , rhs )
              | q( $ ( lhs ) ↔ $ ( rhs ) ) => pure ( lhs , rhs )
              | expr.pi n bi a b => do let l ← mk_local' n bi a simp_lhs_rhs ( b l )
              | ty => pure ( ty , q( True ) )
#align simp_lhs_rhs simp_lhs_rhs

/-- `simp_lhs ty` returns the left-hand side of a simp lemma with type `ty`. -/
private unsafe def simp_lhs (ty : expr) : tactic expr :=
  Prod.fst <$> simp_lhs_rhs ty
#align simp_lhs simp_lhs

-- failed to format: unknown constant 'term.pseudo.antiquot'
/--
      `simp_is_conditional_core ty` returns `none` if `ty` is a conditional simp
      lemma, and `some lhs` otherwise.
      -/
    private
    unsafe
  def
    simp_is_conditional_core
    : expr → tactic ( Option expr )
    |
      ty
      =>
      do
        let ty ← head_beta ty
          match
            ty
            with
            | q( ¬ $ ( lhs ) ) => pure lhs
              | q( $ ( lhs ) = _ ) => pure lhs
              | q( $ ( lhs ) ↔ _ ) => pure lhs
              |
                expr.pi n bi a b
                =>
                do
                  let l ← mk_local' n bi a
                    let some lhs ← simp_is_conditional_core ( b l ) | pure none
                    if
                      bi ≠ BinderInfo.inst_implicit ∧ ¬ ( lhs l ) . has_var
                      then
                      pure none
                      else
                      pure lhs
              | ty => pure ty
#align simp_is_conditional_core simp_is_conditional_core

/-- `simp_is_conditional ty` returns true iff the simp lemma with type `ty` is conditional.
-/
private unsafe def simp_is_conditional (ty : expr) : tactic Bool :=
  Option.isNone <$> simp_is_conditional_core ty
#align simp_is_conditional simp_is_conditional

private unsafe def heuristic_simp_lemma_extraction (prf : expr) : tactic (List Name) :=
  prf.list_constant.toList.filterM is_simp_lemma
#align heuristic_simp_lemma_extraction heuristic_simp_lemma_extraction

/-- Checks whether two expressions are equal for the simplifier. That is,
they are reducibly-definitional equal, and they have the same head symbol. -/
unsafe def is_simp_eq (a b : expr) : tactic Bool :=
  if a.get_app_fn.const_name ≠ b.get_app_fn.const_name then pure false
  else succeeds <| is_def_eq a b Transparency.reducible
#align is_simp_eq is_simp_eq

/-- Reports declarations that are simp lemmas whose left-hand side is not in simp-normal form. -/
unsafe def simp_nf_linter (timeout := 200000) (d : declaration) : tactic (Option String) := do
  let tt ← is_simp_lemma d.to_name |
    pure none
  let-- Sometimes, a definition is tagged @[simp] to add the equational lemmas to the simp set.
    -- In this case, ignore the declaration if it is not a valid simp lemma by itself.
    tt
    ← is_valid_simp_lemma_cnst d.to_name |
    pure none
  let [] ← get_eqn_lemmas_for false d.to_name |
    pure none
  try_for timeout <|
      retrieve do
        let g ← mk_meta_var d
        set_goals [g]
        unfreezing intros
        let (lhs, rhs) ← target >>= simp_lhs_rhs
        let sls ← simp_lemmas.mk_default
        let sls' := sls [d]
        let (lhs', prf1, ns1) ←
          decorate_error "simplify fails on left-hand side:" <|
              simplify sls [] lhs { failIfUnchanged := ff }
        let prf1_lems ← heuristic_simp_lemma_extraction prf1
        if d ∈ prf1_lems then pure none
          else do
            let is_cond ← simp_is_conditional d
            let (rhs', prf2, ns2) ←
              decorate_error "simplify fails on right-hand side:" <|
                  simplify sls [] rhs { failIfUnchanged := ff }
            let lhs'_eq_rhs' ← is_simp_eq lhs' rhs'
            let lhs_in_nf ← is_simp_eq lhs' lhs
            if lhs'_eq_rhs' then do
                let used_lemmas ← heuristic_simp_lemma_extraction (prf1 prf2)
                pure <|
                    pure <|
                      "simp can prove this:\n" ++ "  by simp only " ++ toString used_lemmas ++
                            "\n" ++
                          "One of the lemmas above could be a duplicate.\n" ++
                        "If that's not the case try reordering lemmas or adding @[priority].\n"
              else
                if ¬lhs_in_nf then do
                  let lhs ← pp lhs
                  let lhs' ← pp lhs'
                  pure <|
                      format.to_string <|
                        to_fmt "Left-hand side simplifies from" ++ lhs 2 ++ format.line ++ "to" ++
                                    lhs' 2 ++
                                  format.line ++
                                "using " ++
                              (to_fmt prf1_lems).group.indent 2 ++
                            format.line ++
                          "Try to change the left-hand side to the simplified term!\n"
                else
                  if ¬is_cond ∧ lhs = lhs' then
                    pure <|
                      some <|
                        "Left-hand side does not simplify.\nYou need to debug this yourself using " ++
                          "`set_option trace.simplify.rewrite true`"
                  else pure none
#align simp_nf_linter simp_nf_linter

library_note "simp-normal form"/--
This note gives you some tips to debug any errors that the simp-normal form linter raises.

The reason that a lemma was considered faulty is because its left-hand side is not in simp-normal
form.
These lemmas are hence never used by the simplifier.

This linter gives you a list of other simp lemmas: look at them!

Here are some tips depending on the error raised by the linter:

  1. 'the left-hand side reduces to XYZ':
     you should probably use XYZ as the left-hand side.

  2. 'simp can prove this':
     This typically means that lemma is a duplicate, or is shadowed by another lemma:

     2a. Always put more general lemmas after specific ones:
      ```
      @[simp] lemma zero_add_zero : 0 + 0 = 0 := rfl
      @[simp] lemma add_zero : x + 0 = x := rfl
      ```

      And not the other way around!  The simplifier always picks the last matching lemma.

     2b. You can also use `@[priority]` instead of moving simp-lemmas around in the file.

      Tip: the default priority is 1000.
      Use `@[priority 1100]` instead of moving a lemma down,
      and `@[priority 900]` instead of moving a lemma up.

     2c. Conditional simp lemmas are tried last. If they are shadowed
         just remove the `simp` attribute.

     2d. If two lemmas are duplicates, the linter will complain about the first one.
         Try to fix the second one instead!
         (You can find it among the other simp lemmas the linter prints out!)

  3. 'try_for tactic failed, timeout':
     This typically means that there is a loop of simp lemmas.
     Try to apply squeeze_simp to the right-hand side (removing this lemma from the simp set) to see
     what lemmas might be causing the loop.

     Another trick is to `set_option trace.simplify.rewrite true` and
     then apply `try_for 10000 { simp }` to the right-hand side.  You will
     see a periodic sequence of lemma applications in the trace message.
-/

/-- A linter for simp lemmas whose lhs is not in simp-normal form, and which hence never fire. -/
@[linter]
unsafe def linter.simp_nf : linter where
  test := simp_nf_linter
  auto_decls := true
  no_errors_found := "All left-hand sides of simp lemmas are in simp-normal form."
  errors_found :=
    "SOME SIMP LEMMAS ARE NOT IN SIMP-NORMAL FORM.\nsee note [simp-normal form] for tips how to debug this.\nhttps://leanprover-community.github.io/mathlib_docs/notes.html#simp-normal%20form"
#align linter.simp_nf linter.simp_nf

private unsafe def simp_var_head (d : declaration) : tactic (Option String) := do
  let tt ← is_simp_lemma d.to_name |
    pure none
  let-- Sometimes, a definition is tagged @[simp] to add the equational lemmas to the simp set.
    -- In this case, ignore the declaration if it is not a valid simp lemma by itself.
    tt
    ← is_valid_simp_lemma_cnst d.to_name |
    pure none
  let lhs ← simp_lhs d.type
  let head_sym@(expr.local_const _ _ _ _) ← pure lhs.get_app_fn |
    pure none
  let head_sym ← pp head_sym
  pure <| format.to_string <| "Left-hand side has variable as head symbol: " ++ head_sym
#align simp_var_head simp_var_head

/-- A linter for simp lemmas whose lhs has a variable as head symbol,
and which hence never fire.
-/
@[linter]
unsafe def linter.simp_var_head : linter
    where
  test := simp_var_head
  auto_decls := true
  no_errors_found := "No left-hand sides of a simp lemma has a variable as head symbol."
  errors_found :=
    "LEFT-HAND SIDE HAS VARIABLE AS HEAD SYMBOL.\n" ++
      "Some simp lemmas have a variable as head symbol of the left-hand side:"
#align linter.simp_var_head linter.simp_var_head

private unsafe def simp_comm (d : declaration) : tactic (Option String) := do
  let tt ← is_simp_lemma d.to_name |
    pure none
  let-- Sometimes, a definition is tagged @[simp] to add the equational lemmas to the simp set.
    -- In this case, ignore the declaration if it is not a valid simp lemma by itself.
    tt
    ← is_valid_simp_lemma_cnst d.to_name |
    pure none
  let (lhs, rhs) ← simp_lhs_rhs d.type
  if lhs ≠ rhs then pure none
    else do
      let (lhs', rhs') ← Prod.snd <$> open_pis_metas d >>= simp_lhs_rhs
      let tt ← succeeds <| unify rhs lhs' transparency.reducible |
        pure none
      let tt ← succeeds <| is_def_eq rhs lhs' transparency.reducible |
        pure none
      let-- ensure that the second application makes progress:
        ff
        ← succeeds <| unify lhs' rhs' transparency.reducible |
        pure none
      pure <| "should not be marked simp"
#align simp_comm simp_comm

/-- A linter for commutativity lemmas that are marked simp. -/
@[linter]
unsafe def linter.simp_comm : linter where
  test := simp_comm
  auto_decls := true
  no_errors_found := "No commutativity lemma is marked simp."
  errors_found := "COMMUTATIVITY LEMMA IS SIMP.\n" ++ "Some commutativity lemmas are simp lemmas:"
#align linter.simp_comm linter.simp_comm


import LSpec.LSpec

namespace LSpec

instance (priority := 50) (x y : α) [DecidableEq α] [Repr α] : Testable (x = y) :=
  if h : x = y then
    .isTrue h
  else
    .isFalse h $ s!"Expected to be equal: '{repr x}' and '{repr y}'"

instance (priority := 50) (x y : α) [BEq α] [Repr α] : Testable (x == y) :=
  if h : x == y then
    .isTrue h
  else
    .isFalse h $ s!"Expected to be equal: '{repr x}' and '{repr y}'"

instance (priority := 50) (x y : α) [DecidableEq α] [Repr α] : Testable (x ≠ y) :=
  if h : x ≠ y then
    .isTrue h
  else
    .isFalse h s!"Expected to be different but both equal to '{repr x}'"

instance (priority := 50) (x y : α) [BEq α] [Repr α] : Testable (x != y) :=
  if h : x != y then
    .isTrue h
  else
    .isFalse h s!"Expected to be different but both equal to '{repr x}'"

/--
A fancier example of `Testable` instance that allows us to write:
```lean
#lspec test "forall n < 10, n - 5 < 5" $ ∀ n, n < 10 → n - 5 < 5
```
-/
instance Nat.Testable_forall_lt
  (b : Nat) (p : Nat → Prop)
  [d : (n : Nat) → Testable (p n)] :
    Testable (∀ n, n < b → p n) :=
  match b with
  | 0     => .isTrue (by simp [Nat.not_lt_zero])
  | b + 1 =>
    match Testable_forall_lt b p with
    | .isTrue h =>
      match d b with
      | .isTrue hb =>
        .isTrue $ by
          intros n hn
          cases Nat.eq_or_lt_of_le (Nat.le_of_lt_succ hn) with
          | inl hl => cases hl; assumption
          | inr => apply h; assumption
      | .isMaybe msg => .isMaybe msg
      | .isFalse hb msg =>
        .isFalse (λ h => hb (h _ (Nat.lt_succ_self _))) $
          match msg with
          | some msg => s!"Fails on input {b}. {msg}"
          | none     => s!"Fails on input {b}."
      | .isFailure msg => .isFailure msg
    | .isMaybe msg => .isMaybe msg
    | .isFalse h msg => .isFalse (λ h' => h λ n hn => h' _ (Nat.le_step hn)) msg
    | .isFailure msg => .isFailure msg

end LSpec


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

universes u v l u_1

namespace Mathlib

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

-- `functor` is indeed a categorical functor

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

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

-- applicative laws

-- default functor law

-- applicative "law" derivable from other laws

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

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

-- monad laws

-- monad "law" derivable from other laws

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

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

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

-- instances of previously defined monads

namespace id

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

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

end id

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

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

namespace state_t

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

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

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

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

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

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

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

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

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

end state_t

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

namespace except_t

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

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

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

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

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

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

end except_t

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

namespace reader_t

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

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

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

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

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

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

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

end reader_t

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

namespace option_t

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

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

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

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

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

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

end option_t

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


import Smt

theorem cong (p q : Prop) (f : Prop → Prop) : p = q → f p = f q := by
  smt


import dialectica
import proof
import realizers
import majorizability
import data.equiv.basic

section

  parameters {ι : Type} {gri : ground_interpretation ι}
  local notation `𝔽` := formula ι gri
  local notation `𝕋` := type ι gri
  variables {greq : Π {i : ι}, ∥𝕏 i // gri ∥ → ∥𝕏 i // gri ∥ → 𝔽}
  local infixr `≅` : 35 := formula.eqext @greq

  open formula (𝕎_inh' ℂ_inh')
  set_option pp.proofs true
  def metatheorem
    (𝕄 : 𝕋 → 𝕋) [maj_type 𝕄] (maj : majorizability 𝕄) (admissible : admissible_greq @greq)
    (σ : 𝕋) (A B : ∥𝕆 // gri∥ → ∥σ∥ → 𝔽)
    (trivialA : ∀ a b x y, (A a b).dia x y ↔ ∥A a b∥)
    (trivialB : ∀ a b x y, (B a b).dia x y ↔ ∥B a b∥)
    (Γ : premises')
    (premise_realizer : Π {γ : 𝔽}, γ ∈ Γ → dia.realizer γ)
    (prf : proof @greq {with_markov := tt, with_ip := tt} Γ $ ∀∀ x : ∥σ∥, ((∀∀ u : ∥𝕆∥, A u x) ⟹ (∃∃v : ∥𝕆∥, B v x))) :
    {φ : ∥𝕄 σ∥ → ℕ // ∀ (x : ∥σ∥) (x' : ∥𝕄 σ∥) (_ : maj.majorizes x x'), (∀ u : ℕ, u ≤ φ x' → ∥A u x∥) → (∃ v : ℕ, v ≤ φ x' ∧ ∥B v x∥)}
    :=
    let ⟨t, h⟩ := prf.dia_realize admissible @premise_realizer in
    let y : ∥σ∥ → (Σ (x : ∥σ∥), (Π (x_1 : ℕ), (A x_1 x).mwc.fst) × Π (x_1 : ℕ), (B x_1 x).mwc.fst → (B x_1 x).mwc.snd)
      := λ x, sigma.mk x ⟨(λ _, 𝕎_inh'), (λ _ _, ℂ_inh')⟩ in
    let t₁ : ∥σ∥ → ℕ := λ x, ((t x).1 (λ _, 𝕎_inh') (λ _ _, ℂ_inh')).1 in
    let t₂ : ∥σ∥ → ℕ := λ x, ((t x).2 (λ _, 𝕎_inh')).1 in
    have h' : (∥σ∥ → ℕ) = ∥σ ↣ 𝕆∥ := rfl,
    let m₁ := maj.majorizer (cast h' t₁) in
    let m₂ := maj.majorizer (cast h' t₂) in
    let m₁' := type.cast (maj_type.𝕄_app σ 𝕆) m₁ in
    let m₂' := type.cast (maj_type.𝕄_app σ 𝕆) m₂ in
    let m₁'' : ∥𝕄 σ∥ → ℕ := λ x', type.cast maj_type.𝕄_𝕆 (type.cast (maj_type.𝕄_app σ 𝕆) m₁ x') in
    let m₂'' : ∥𝕄 σ∥ → ℕ := λ x', type.cast maj_type.𝕄_𝕆 (type.cast (maj_type.𝕄_app σ 𝕆) m₂ x') in
    let Φ : ∥𝕄 σ∥ → ℕ := λ x', (max (m₁'' x') (m₂'' x')) in
    ⟨Φ, begin
      intros x x' xmaj hA,
      use t₂ x,
      split, {
        have t₂_le_m₂ := maj.majorizes_le (maj.majorizes_app x x' (cast h' t₂) m₂ xmaj (by simp only [cast_eq]; apply maj.majorizer_majorizes)),
        -- have : (cast h' t₂) x = t₂ x := by simp,
        -- rw this at t₂_le_m₂, clear this,
        have : m₂'' x' ≤ Φ x' := by { dsimp only [Φ], exact le_max_right _ _, },
        exact le_trans t₂_le_m₂ this,
      }, {
        dsimp' at h,
        simp_rw [trivialA, trivialB] at h,
        specialize h (y x),
        dsimp at h,
        have : ((t x).snd (λ (_x : ℕ), 𝕎_inh')).fst = t₂ x := by refl,
        rw this at h,
        apply h,
        apply hA,
        have : ((t x).fst (λ (_x : ℕ), 𝕎_inh') (λ (_x : ℕ) (_x_1 : (B _x x).mwc.fst), ℂ_inh')).fst = t₁ x, refl,
        rw this, clear this,
        have t₁_le_m₁ := maj.majorizes_le (maj.majorizes_app x x' (cast h' t₁) m₁ xmaj (by simp only [cast_eq]; apply maj.majorizer_majorizes)),
        -- have : (cast h' t₁) x = t₁ x := by simp,
        -- rw this at t₁_le_m₁, clear this,
        have : m₁'' x' ≤ Φ x' := by { dsimp only [Φ], exact le_max_left _ _, },
        exact le_trans t₁_le_m₁ this,
      }
    end⟩

end

#print axioms metatheorem
  -- open formula (𝕎_inh' ℂ_inh')
  -- set_option pp.proofs true
  -- def metatheorem (𝕄 : 𝕋 → 𝕋) [maj_type 𝕄] (maj : majorizability 𝕄) (admissible : admissible_greq @greq) {σ : 𝕋} (A B : ∥𝕆 // gri∥ → ∥σ∥ → 𝔽) (Γ : premises') (premise_realizer : Π {γ : 𝔽}, γ ∈ Γ → dia.realizer γ)
  -- -- (trivialA : ∀ x u, (A x u).dia 𝕎_inh' ℂ_inh' ↔ ∥A x u∥) (trivialB : ∀ x v, (B x v).dia 𝕎_inh' ℂ_inh' ↔ ∥B x v∥)
  -- (prf : proof @greq {with_markov := tt, with_ip := tt} Γ (∀∀ x : ∥σ∥, ((∀∀ u : ∥𝕆∥, A u x) ⟹ (∃∃ v : ∥𝕆∥, B v x))))
  -- : {φ : ∥𝕄 σ∥ → ∥𝕆 // gri∥ // ∀ (x : ∥σ∥) (x' : ∥𝕄 σ∥) (_ : maj.majorizes x x'), (∀ u : ℕ, u ≤ φ x' → ∥A u x∥) → (∃ v : ℕ, v ≤ φ x' ∧ ∥B v x∥)} :=
  -- let ⟨t, h⟩ := prf.dia_realize admissible @premise_realizer in
  -- by {
  --   dsimp' at t,
  --   dsimp' at h,
  --   type_check t,
  --   have trivialA : ∀ a b x y, (A a b).dia x y ↔ ∥A a b∥ := sorry,
  --   have trivialB : ∀ a b x y, (B a b).dia x y ↔ ∥B a b∥ := sorry,
  --   simp_rw [trivialA, trivialB] at h,
  --   -- set t' := λ y : (Σ (x : ∥σ∥), (Π (x_1 : ℕ), (A x_1 x).mwc.fst) × Π (x_1 : ℕ), (B x_1 x).mwc.fst → (B x_1 x).mwc.snd), t y.fst with ht',
  --   set y' : ∥σ∥ → (Σ (x : ∥σ∥), (Π (x_1 : ℕ), (A x_1 x).mwc.fst) × Π (x_1 : ℕ), (B x_1 x).mwc.fst → (B x_1 x).mwc.snd)
  --     := λ x, sigma.mk x ⟨(λ _, 𝕎_inh'), (λ _ _, ℂ_inh')⟩,
  --   set t₁ := λ x, (t x).1,
  --   set t₂ := λ x, (t x).2,
  --   let t₁' : ∥σ∥ → ℕ := λ x, (t₁ x (y' x).2.1 (y' x).2.2).1,
  --   let t₂' : ∥σ∥ → ℕ := λ x, (t₂ x (y' x).2.1).1,
  --   let t₁'' : ∥σ∥ → ℕ := λ x, (t₁ x (λ _, 𝕎_inh') (λ _ _, ℂ_inh')).1,
  --   let t₂'' : ∥σ∥ → ℕ := λ x, (t₂ x (λ _, 𝕎_inh')).1,
  --   have : (∥σ∥ → ℕ) = ∥σ ↣ 𝕆∥ := sorry,
  --   let m₁ := (maj.majorizer (cast this t₁'')),
  --   let m₂ := (maj.majorizer (cast this t₂'')),
  --   set m₁' := type.cast (maj_type.𝕄_app σ 𝕆) m₁ with eq_m₁',
  --   set m₂' := type.cast (maj_type.𝕄_app σ 𝕆) m₂ with eq_m₂',
  --   ss at m₁',
  --   ss at m₂',
  --   let Φ : ∥𝕄 σ∥ → ℕ := λ x', type.cast maj_type.𝕄_𝕆 (max (m₁' x') (m₂' x')),

  --   refine subtype.mk Φ _,
  --   intros x x' xmaj h',
  --   use t₂'' x,
  --   split,
  --   have := maj.majorizes_app x x' (cast this t₂'') m₂ xmaj sorry,
  --   have := maj.majorizes_le this,
  --   dsimp at this,
  --   rw ←eq_m₂' at this_1,
  -- }


import .atom .ldq

variables {α β : Type}

open tactic atom_eq_type

def lift_eq_qe (β : Type) [atom_eq_type α β] (qe : list α → fm α) (as : list α) : fm α :=
  let ntas := @list.filter _ (λ (a : α), ¬ atom_eq_type.trivial β a)
    begin
      apply dec_not_pred_of_dec_pred (trivial β),
      apply atom_eq_type.dec_triv
    end as in
  match @list.first _ (solv0 β)
        begin apply atom_eq_type.dec_solv0 end ntas with
  | none := qe ntas
  | some (eq,rest) :=
    list_conj  (list.map (λ (a : α), A' (subst0 β eq a)) rest)
  end

lemma leq_qe_prsv [atom_eq_type α β] (qe : list α → fm α)
  (H : ∀ (as : list α), (∀ (a : α), a ∈ as → atom_type.dep0 β a ∧ ¬ solv0 β a) → qe_prsv β qe as) :
  ∀ (as : list α), (∀ (a : α), a ∈ as → atom_type.dep0 β a) → qe_prsv β (lift_eq_qe β qe) as :=
begin
  intros as Has, unfold qe_prsv, intros bs,
  unfold lift_eq_qe, simp,
  cases (@cases_first _ (solv0 β) (dec_solv0 _ β)
    (@list.filter _ (λ (a : α), ¬trivial β a)
      (begin apply dec_not_pred_of_dec_pred (trivial β),
      apply atom_eq_type.dec_triv end) as)) with HC HC,
  rewrite HC^.elim_left,
  unfold lift_eq_qe, unfold qe_prsv at H,
  apply iff.trans, apply H, intros a Ha,
  apply and.intro, apply Has, apply mem_of_mem_filter Ha,
  apply HC^.elim_right, apply Ha,
  apply ex_iff_ex, intro b,
  apply iff.intro, intros HL a Ha,
  cases (dec_triv α β a) with HT HT, apply HL,
  apply mem_filter_of_mem, apply HT, apply Ha,
  apply true_triv, apply HT,
  intros HR a Ha, apply HR, apply mem_of_mem_filter,
  apply Ha,
  cases HC with eqn HC, cases HC with as' HC,
  cases HC with H1 H2, cases H2 with H2 H3,
  rewrite H1, unfold lift_eq_qe,
  rewrite exp_I_list_conj, rewrite map_compose,

  apply iff.intro, intro HL,
  existsi (list.nth_dft (atom_type.inh α β) bs ((@atom_eq_type.dest_solv0 α β _ eqn H2)-1)),
  intros a Ha,
  cases (dec_triv α β a) with HT HT,
  cases (atom_type.dec_eq α β a eqn) with HE HE,
  apply (atom_eq_type.subst_prsv H2)^.elim_left,
  apply HL, apply mem_map_of_mem,
  have HM : a ∈ (eqn::as'), apply (H3 a)^.elim_left,
  apply mem_filter_of_mem, apply HT,
  apply Ha, cases HM with HM HM,
  apply absurd HM HE, apply HM,
  rewrite HE,
  apply (atom_eq_type.subst_prsv H2)^.elim_left,
  apply atom_eq_type.true_subst, apply H2,
  apply true_triv, apply HT,
  intros HR p Hp,
  cases (list.exists_of_mem_map Hp) with a Ha,
  cases Ha with Ha Ha', rewrite Ha',
  clear Hp, clear Ha', clear p,
  apply (atom_eq_type.subst_prsv H2)^.elim_right,
  cases HR with b Hb,
  have Hbe := atom_eq_type.solv0_eq H2 (Hb eqn _),
  have H4 := (H3 a)^.elim_right _,
  rewrite (nth_dft_pred _) at Hbe,
  rewrite Hbe, apply Hb,
  apply mem_of_mem_filter H4,
  apply dest_pos,
  have H5 := (H3 eqn)^.elim_right _,
  apply of_mem_filterH5,
  apply or.inl, refl, apply or.inr Ha,
  have H5 := (H3 eqn)^.elim_right _,
  apply mem_of_mem_filter H5, apply or.inl, refl
end

def lift_dnfeq_qe (β : Type) [atom_eq_type α β] (qe : list α → fm α) := lift_dnf_qe β (@lift_eq_qe α β _ qe)

lemma leq_qfree [HA : atom_eq_type α β] (qe : list α → fm α)
(Hqe : ∀ (as' : list α), allp (atom_type.dep0 β) as' → qfree (qe as'))
(l : list α) (Hl : allp (atom_type.dep0 β) l) : qfree (lift_eq_qe β qe l) :=
begin
  unfold lift_eq_qe, simp,
  cases (list.first (solv0 β) _) with pr,
  apply Hqe, intros x Hx, apply Hl,
  apply mem_of_mem_filter Hx, cases pr with eqn as',
  apply qfree_list_conj, intros a Ha,
  cases (list.exists_of_mem_map Ha) with a' Ha',
  rewrite Ha'^.elim_right, simp
end

lemma ldeq_qfree [atom_eq_type α β] (qe : list α → fm α)
  (Hqe : ∀ (as') (Has' : allp (@atom_type.dep0 α β _) as'), qfree (qe as'))
  (p : fm α) : qfree (lift_dnfeq_qe β qe p) :=
begin
  unfold lift_dnfeq_qe, apply ldq_qfree,
  intros as Has, apply leq_qfree, apply Hqe,
  apply Has
end

lemma ldeq_prsv [atom_eq_type α β] (qe : list α → fm α)
  (Hqe : ∀ (as) (Has : allp (@atom_type.dep0 α β _) as), qfree (qe as))
  (Has : ∀ (as : list α), (∀ (a' : α), a' ∈ as → atom_type.dep0 β a' ∧ ¬ solv0 β a') → qe_prsv β qe as)
  (p : fm α) (bs : list β) : I (lift_dnfeq_qe β qe p) bs ↔ I p bs :=
begin
  unfold lift_dnfeq_qe, apply ldq_prsv, apply leq_qfree,
  apply Hqe, apply leq_qe_prsv, apply Has
end