import data.cpi.species.normalise data.cpi.species.prime

namespace cpi
namespace species
namespace normalise

variables {ℍ : Type} {ω : context}
open_locale normalise

/-- Determine if normalising a species or choice yields a list of primes. Note
    that choices are inherently prime. -/
@[reducible]
def to_kind' : ∀ (k : kind), kind' ℍ k
| kind.species := kind'.atom
| kind.choices := kind'.choices

lemma normalise_nil {Γ} : normalise (@nil ℍ ω Γ) = nil
  := by unfold normalise normalise_to parallel.from_list

/-- If we have a list of species which are an atom, then it must be a singleton
    list. -/
def atom_singleton_parallel {Γ} :
  ∀ {As : list (species ℍ ω Γ)}
  , atom kind'.atom (parallel.from_list As)
  → Σ' (A : species ℍ ω Γ), As = [A]
| [] atom := by { exfalso, cases atom }
| [A] atom := ⟨ A, rfl ⟩
| (A::B::As) atom := by { exfalso, cases atom }

private lemma partition_restriction_atom {Γ} (M : affinity ℍ) :
  ∀ (As : list (species ℍ ω (context.extend (M.arity) Γ)))
    (C : species ℍ ω (context.extend (M.arity) Γ))
    (h : ∀ A ∈ As, normalise.atom normalise.kind'.atom A ∧ level.zero ∈ A)
  , partition_restriction M As C (λ x mem, (h x mem).1)
  = ⟨ As, [], equiv.parallel_nil₂, h, λ x mem, by cases mem ⟩
| [] C h := begin
  simp only [partition_restriction],
  from ⟨ rfl, heq.rfl ⟩,
end
| (A::As) C h := begin
  simp only [partition_restriction],

  have h := partition_restriction_atom As (C |ₛ A)
    (λ x mem, h x (list.mem_cons_of_mem _ mem)),
  rw h, clear h,

  simp only [partition_restriction._match_1, dite],
  cases (@free_in.decidable ℍ ω _ _ level.zero A),

  case is_false : notFree {
    simp only [],
    from absurd (h A (list.mem_cons_self A _)).2 notFree,
  },

  simp only [],
  from ⟨ ⟨ rfl, rfl ⟩, heq.rfl ⟩,
end

private lemma undo_choice {Γ} (M : affinity ℍ) :
  ∀ (A : species ℍ ω (context.extend (M.arity) Γ))
    (As : list (species ℍ ω (context.extend (M.arity) Γ)))
  , atom (kind'.in_nu M) (parallel.from_list (A::As))
  → (∀ (B : whole ℍ ω kind.species (context.extend (M.arity) Γ)), B ∈ (list.cons A As) → atom kind'.atom B)
  → ∀ B ∈ (list.cons A As), normalise.atom normalise.kind'.atom B ∧ level.zero ∈ B
| A [] atomAs atomEach B mem := begin
  -- We're a singleton list, so must be nu_one.
  cases mem, case or.inr { cases mem }, subst mem,
  cases atomAs, case atom.nu_cons { cases atomEach _ (list.mem_cons_self _ _) },

  from ⟨ ‹ atom kind'.atom B ›, ‹ level.zero ∈ B › ⟩,
end
| A (A'::As) atomAs atomEach B mem := begin
  -- Similarly, we must be nu_cons.
  cases atomAs, case atom.nu_one : atomA { cases atomA },

  cases mem,
  case or.inl { subst mem, from ⟨ ‹ atom kind'.atom B ›, ‹ level.zero ∈ B › ⟩ },
  case or.inr {
    from undo_choice A' As ‹ atom (kind'.in_nu M) (parallel.from_list (A' :: As)) ›
      (λ x mem, atomEach x (list.mem_cons_of_mem _ mem))
      _ mem,
  }
end

private lemma parallel_restriction_atom {Γ} (M : affinity ℍ) :
  ∀ (A : list (species ℍ ω (context.extend (M.arity) Γ)))
    (atomA : atom (kind'.in_nu M) (parallel.from_list A))
    (atomEach : ∀ (B : whole ℍ ω kind.species (context.extend (M.arity) Γ)), B ∈ A → atom kind'.atom B)
  , parallel.from_list ((normalise_restriction M A atomEach).fst)
  = ν(M) parallel.from_list A
| As atomAs atomEach := begin
  simp only [normalise_restriction],

  cases As with A As,
  case list.nil { cases atomAs, cases atomAs_a },

  have atomLike : ∀ B ∈ (list.cons A As), normalise.atom normalise.kind'.atom B ∧ level.zero ∈ B
    := undo_choice M A As atomAs atomEach,

  rw partition_restriction_atom M (A::As) nil atomLike,
  simp only [normalise_restriction._match_2],

  rcases defB : build_restriction M (A :: As) [] atomLike _ with ⟨ As₂, eq₂, atomAs₂ ⟩,
  simp only [build_restriction] at defB,
  simp only [normalise_restriction._match_1],

  rw ← defB.1,
  from rfl,
end

lemma normalise_atom :
  ∀ {sk} {k : kind' ℍ sk} {Γ} {A : whole ℍ ω sk Γ}
  , atom k A → normalise A = A
| sk k Γ A atom := begin
  induction atom; try { assumption },

  -- The proof for this is pretty simple, and follows the same template:
  --
  --  • Induct over the child fields:
  --      rcases normalise_to A with ⟨ A', eqA, atomA ⟩ assume ih, simp only [] at ih, subst ih,
  --    We need the weird "assume ih, ..." lines to reintroduce the induction hypothesis
  --    - rcases is a little weird here.
  --  • Unfold the internal matches
  --  • Actually prove this case

  case atom.choice_cons : Γ A As atomA atomAs ihA ihAs {
    simp only [normalise, normalise_to, parallel.from_list] at ⊢ ihA ihAs,
    rcases normalise_to A with ⟨ A', eqA, atomA' ⟩,     assume ih, simp only [] at ih, subst ih,
    rcases normalise_to As with ⟨ As', eqAs, atomAs' ⟩, assume ih, simp only [] at ih, subst ih,
    simp only [normalise_to._match_1, normalise_to._match_2], clear eqA eqAs atomA' atomAs',

    cases atom_singleton_parallel atomA with A' h, subst h,
    simp only [list.cons_append, list.nil_append, parallel.from_list],

    cases As',
    case list.nil { cases atomAs, cases atomAs_a },
    from rfl,
  },

  case atom.nu_cons : Γ M A As atomA usesA atomAs ihA ihAs {
    simp only [normalise, normalise_to, parallel.from_list] at ⊢ ihA ihAs,
    rcases normalise_to A with ⟨ A', eqA, atomA' ⟩,     assume ih, simp only [] at ih, subst ih,
    rcases normalise_to As with ⟨ As', eqAs, atomAs' ⟩, assume ih, simp only [] at ih, subst ih,
    simp only [normalise_to._match_1, normalise_to._match_2], clear eqA eqAs atomA' atomAs',

    cases atom_singleton_parallel atomA with A' h, subst h,
    simp only [list.cons_append, list.nil_append, parallel.from_list],

    cases As',
    case list.nil { cases atomAs, cases atomAs_a },
    from rfl,
  },

  case atom.apply {
    simp only [normalise, normalise_to, parallel.from_list],
    from ⟨ rfl, heq.rfl, heq.rfl ⟩,
  },

  case atom.choice : Γ As atomAs ih {
    simp only [normalise, normalise_to, parallel.from_list] at ⊢ ih,
    rcases normalise_to As with ⟨ As', eqAs, atomAs' ⟩, assume ih, simp only [] at ih, subst ih,
    simp only [normalise_to._match_5], clear eqAs,
    from rfl,
  },

  case atom.restriction : Γ M A atomA ih {
    simp only [normalise, normalise_to, parallel.from_list] at ⊢ ih,
    rcases normalise_to A with ⟨ A', eqA, atomA' ⟩, assume ih, simp only [] at ih, subst ih,
    simp only [normalise_to._match_4],

    rcases h : normalise_restriction M A' atomA' with ⟨ A₂, eqA₂, atomA₂ ⟩,
    simp only [normalise_to._match_3],

    suffices : parallel.from_list (normalise_restriction M A' atomA').fst
             = ν(M) parallel.from_list A',
      rw h at this, from this,
    from parallel_restriction_atom M A' atomA atomA',
  },

  case normalise.atom.empty { simp only [normalise, normalise_to, parallel.from_list] },

  case atom.cons_nil : Γ f π As atomAs ih {
    unfold normalise, unfold1 normalise_to, simp only [normalise, normalise_to] at ih,
    rcases normalise_to As with ⟨ As', eqAs, atomAs' ⟩, assume ih, simp only [] at ih, subst ih,
    rcases defNil : normalise_to nil with ⟨ nil', eqNil, atomNil' ⟩,
    simp only [normalise_to._match_6, normalise_to._match_7],

    have : parallel.from_list nil' = nil,
    { simp only [normalise_to] at defNil,
      rw ← (psigma.mk.inj defNil).1,
      from rfl },
    from ⟨ rfl, heq.rfl, heq_of_eq this, rfl ⟩,
  },

  case atom.cons_species : Γ f π A As atomA atomAs ihA ihAs {
    simp only [normalise, normalise_to, parallel.from_list] at ⊢ ihA ihAs,
    rcases normalise_to A with ⟨ A', eqA, atomA' ⟩,     assume ih, simp only [] at ih, subst ih,
    rcases normalise_to As with ⟨ As', eqAs, atomAs' ⟩, assume ih, simp only [] at ih, subst ih,
    simp only [normalise_to._match_6, normalise_to._match_7],

    from ⟨ rfl, heq.rfl, heq.rfl, rfl ⟩,
  }
end

/-- Show that any atomic species must be prime. -/
lemma atom_prime : ∀ {Γ} {A : species ℍ ω Γ}, atom kind'.atom A → prime A
| Γ A atomA := ⟨ λ isNil, begin
    unfold_projs at isNil, unfold equiv at isNil,
    rw [normalise_atom atomA] at isNil, subst isNil,
    rw normalise_nil at atomA, cases atomA,
  end, λ B₁ B₂ equ, begin
    unfold_projs at equ, unfold equiv at equ,
    rw [normalise_atom atomA] at equ, subst equ,

    unfold normalise normalise_to at atomA,
    rcases dB₁ : normalise_to B₁ with ⟨ nB₁, eqB₁, atomB₁ ⟩, rw dB₁ at atomA,
    rcases dB₂ : normalise_to B₂ with ⟨ nB₂, eqB₂, atomB₂ ⟩, rw dB₂ at atomA,
    unfold normalise_to._match_2 normalise_to._match_1 at atomA,

    cases nB₁,
    case list.nil {
      -- nB₁ is nil, then B₁ ≈ nil
      simp only [list.nil_append] at atomA,
      suffices : parallel.from_list (normalise_to B₁).fst = normalise nil,
        from or.inl this,

      rw [dB₁, normalise_nil],
      from rfl,
    },

    case list.cons : nB₁' nBs₁ {
      simp only [list.cons_append] at atomA,
      cases h : nBs₁ ++ nB₂,
      case list.nil {
        -- nBs₁ ++ nB₂ is nil, then B₂ is nil, thus B₁ ≈ nil
        suffices : parallel.from_list (normalise_to B₂).fst = normalise nil,
          from or.inr this,

        simp only [dB₂, normalise_nil, (list.append_eq_nil.mp h).2],
        from rfl,
      },

      case list.cons {
        -- This would mean we have atom (nB₁' |ₛ parallel.from_list (nBs₁ ++ nB₂)),
        -- which is impossible.
        rw h at atomA, cases atomA,
      }
    }
  end ⟩

/-- Decompose a species into a list of prime species. -/
def prime_decompose {Γ} : species ℍ ω Γ → list (prime_species ℍ ω Γ)
| A :=
  let ⟨ As, _, atomAs ⟩ := normalise_to A in
  list.map_witness As (λ A mem, ⟨ A, atom_prime (atomAs A mem) ⟩ )

lemma prime_decompose.equiv {Γ} {A B : species ℍ ω Γ} (h : A ≈ B)
  : prime_decompose A = prime_decompose B := begin
  suffices : (normalise_to A).1 = (normalise_to B).1,
    unfold prime_decompose,
    rcases defA : normalise_to A with ⟨ A', eqA, atomA ⟩,
    rcases defB : normalise_to B with ⟨ B', eqB, atomB ⟩,
    rw [defA, defB] at this, simp only [] at this, subst this,
    from rfl,

  from equiv.normalise_to h,
end

/-- prime_decompose' on setoids. -/
def prime_decompose' {Γ} : species' ℍ ω Γ → multiset (prime_species' ℍ ω Γ)
  := begin
  refine quot.map (λ A, list.map quotient.mk (prime_decompose A)) _,

  assume A B equi,
  show (list.map quotient.mk (prime_decompose A))
     ~ (list.map quotient.mk (prime_decompose B)),

  rw prime_decompose.equiv equi,
end

lemma prime_decompose.nil {Γ} : prime_decompose (@nil ℍ ω Γ) = [] := begin
  simp only [prime_decompose],
  rcases h : normalise_to nil with ⟨ xs, eql, atom ⟩,
  simp only [normalise_to] at h, cases h, clear h,
  from rfl,
end

lemma normalise_to.parallel {Γ} (A B : species ℍ ω Γ)
  : (normalise_to (A |ₛ B)).fst = (normalise_to A).fst ++ (normalise_to B).fst := begin
  unfold normalise_to,

  rcases normalise_to A with ⟨ A', eqA, atomA' ⟩,
  rcases normalise_to B with ⟨ B', eqB, atomB' ⟩,
  from rfl,
end

lemma prime_decompose.parallel {Γ} (A B : species ℍ ω Γ)
  : prime_decompose (A |ₛ B) = prime_decompose A ++ prime_decompose B
  := begin
  unfold prime_decompose,

  have h := normalise_to.parallel A B,
  rcases normalise_to A with ⟨ A', eqA, atomA ⟩, assume h,
  rcases normalise_to B with ⟨ B', eqB, atomB ⟩, assume h,
  rcases normalise_to (A |ₛ B) with ⟨ AB', eqAB, atomAB ⟩, assume h,

  unfold prime_decompose._match_1, unfold_projs at h, clear eqA eqB eqAB A B,

  induction A' generalizing AB',
  case list.nil {
    simp only [list.append, list.nil_append, list.map_witness] at ⊢ h,
    subst h,
  },
  case list.cons : A' As' ih {
    simp only [list.append, list.cons_append, list.map_witness] at ⊢ h,
    subst h,
    simp only [list.map_witness],
    from ⟨ rfl, ih _ _ _ rfl ⟩,
  }
end

lemma prime_decompose'.nil {Γ} : prime_decompose' ⟦ @nil ℍ ω Γ ⟧ = [] := quot.sound(begin
  simp only [prime_decompose.nil],
  from refl _,
end)

lemma prime_decompose'.parallel {Γ} (A B : species ℍ ω Γ)
  : prime_decompose' ⟦A |ₛ B⟧ = prime_decompose' ⟦ A ⟧ + prime_decompose' ⟦ B ⟧
  := quot.sound (begin
    simp only [prime_decompose.parallel, list.map_append],
    from refl _,
  end)

axiom normalise_to.prime {Γ} (A : species ℍ ω Γ)
  : prime A → (normalise_to A).fst = [A]

lemma prime_decompose.prime {Γ} (A : prime_species ℍ ω Γ)
  : prime_decompose A.val = [A] := begin
  unfold prime_decompose,

  have h := normalise_to.prime A.val A.property,
  rcases normalise_to A.val with ⟨ A', eqA, atomA ⟩, assume h,

  simp only [] at h, subst h,
  unfold prime_decompose._match_1 list.map_witness,
  simp only [subtype.eta],
  from ⟨ rfl, rfl ⟩,
end

lemma prime_decompose'.prime {Γ} (A : prime_species' ℍ ω Γ)
  : prime_decompose' (prime_species.unwrap A) = [ A ]
  := begin
    rcases quot.exists_rep A with ⟨ ⟨ A, prime ⟩, eq ⟩, subst eq,

    show prime_decompose' ⟦A⟧ = ⟦ [quot.mk setoid.r ⟨A, prime⟩] ⟧,

    suffices : list.map quotient.mk (prime_decompose A) ≈ [quot.mk setoid.r ⟨A, prime⟩],
      from quot.sound this,

    rw prime_decompose.prime ⟨ A, prime ⟩,
    from refl _,
  end

end normalise
end species
end cpi

#lint-


import Lean.Aesop

theorem EqIffBeqTrue [DecidableEq α] {a b : α} : a = b ↔ ((a == b) = true) :=
⟨decideEqTrue, ofDecideEqTrue⟩

theorem NeqIffBeqFalse [DecidableEq α] {a b : α} : a ≠ b ↔ ((a == b) = false) :=
⟨decideEqFalse, ofDecideEqFalse⟩

theorem decide_eq_true_iff (p : Prop) [Decidable p] : (decide p = true) ↔ p :=
⟨ofDecideEqTrue, decideEqTrue⟩

theorem decide_eq_false_iff_not (p : Prop) [Decidable p] : (decide p = false) ↔ ¬ p :=
⟨ofDecideEqFalse, decideEqFalse⟩

theorem optParam_eq (α : Sort u) (default : α) : optParam α default = α := rfl

def not_false := notFalse
def proof_irrel := @proofIrrel
def congr_fun := @congrFun
def congr_arg := @congrArg
def of_eq_true := @ofEqTrue

-- TODO subst builder
theorem not_of_eq_false {p : Prop} (h : p = False) : ¬p := fun hp => h ▸ hp

-- TODO reflexivity default tactic
-- TODO How to use a lemma like this? Imo this is a nice example of e-matching.
theorem cast_proof_irrel (h₁ h₂ : α = β) (a : α) : cast h₁ a = cast h₂ a := rfl

def cast_eq := @castEq

-- TODO make this a norm lemma?
theorem Ne.def (a b : α) : (a ≠ b) = ¬ (a = b) := rfl

def false_of_ne := @falseOfNe
def ne_false_of_self := @neFalseOfSelf
def ne_true_of_not := @neTrueOfNot
def true_ne_false := trueNeFalse
def eq_of_heq := @eqOfHEq
def heq_of_eq := @heqOfEq
def heq_of_heq_of_eq := @heqOfHEqOfEq
def heq_of_eq_of_heq := @heqOfEqOfHEq
def type_eq_of_heq := @typeEqOfHEq
def eq_rec_heq := @eqRecHEq

-- TODO heq refl default tactic
theorem heq_of_eq_rec_left {φ : α → Sort v} {a a' : α} {p₁ : φ a} {p₂ : φ a'} :
  (e : a = a') → (h₂ : Eq.rec (motive := fun a _ => φ a) p₁ e = p₂) → p₁ ≅ p₂
| rfl, rfl => HEq.rfl

theorem heq_of_eq_rec_right {φ : α → Sort v} {a a' : α} {p₁ : φ a} {p₂ : φ a'} :
  (e : a' = a) → (h₂ : p₁ = Eq.rec (motive := fun a _ => φ a) p₂ e) → p₁ ≅ p₂
| rfl, rfl => HEq.rfl

theorem of_heq_true (h : a ≅ True) : a := of_eq_true (eq_of_heq h)

def cast_heq := @castHEq

-- TODO use applicable hyps by default
def And.elim (f : a → b → α) (h : a ∧ b) : α := by aesop (safe [f])

theorem And.symm : a ∧ b → b ∧ a := by aesop

-- TODO automatic cases on or in hyp (needs per-hyp rules)
-- TODO cases builder
theorem Or.elim {a b c : Prop} (h₁ : a → c) (h₂ : b → c) (h : a ∨ b) : c := by
  cases h <;> aesop

-- TODO make normalisation a fixpoint loop?
-- TODO deal with negation
-- TODO use hyps in the context by default
theorem not_not_em (a : Prop) : ¬¬(a ∨ ¬a) := by
  show ((a ∨ (a → False)) → False) → False
  exact fun H => H (Or.inr fun h => H (Or.inl h))

theorem Or.symm (h : a ∨ b) : b ∨ a := by
  cases h <;> aesop

-- TODO use iff in the context as norm rule?
-- TODO allow local hyps to be added as norm simp rules
def Iff.elim (f : (a → b) → (b → a) → c) (h : a ↔ b) : c := by
  admit
  -- aesop (norm [h (builder simp)])

-- TODO add Iff.intro as default rule
theorem iff_comm : (a ↔ b) ↔ (b ↔ a) := by
  aesop (safe [Iff.intro])

theorem iff_iff_implies_and_implies : (a ↔ b) ↔ (a → b) ∧ (b → a) :=
  ⟨fun ⟨ha, hb⟩ => ⟨ha, hb⟩, fun ⟨ha, hb⟩ => ⟨ha, hb⟩⟩

-- TODO don't do contextual simp for all hyps by default (so this should fail)
theorem Eq.to_iff : a = b → (a ↔ b) := by
  aesop

theorem neq_of_not_iff : ¬(a ↔ b) → a ≠ b := mt Eq.to_iff

theorem of_iff_true (h : a ↔ True) : a := by aesop

theorem not_of_iff_false : (a ↔ False) → ¬a := Iff.mp

theorem not_not_intro : a → ¬¬a := fun a h => h a

theorem iff_true_intro (h : a) : a ↔ True := by aesop

theorem iff_false_intro (h : ¬a) : a ↔ False := by aesop

theorem not_iff_false_intro (h : a) : ¬a ↔ False := by aesop

theorem not_not_not : ¬¬¬a ↔ ¬a := ⟨mt not_not_intro, not_not_intro⟩

theorem imp_congr_left (h : a ↔ b) : (a → c) ↔ (b → c) := by aesop

-- TODO Iff elim
theorem imp_congr_right (h : a → (b ↔ c)) : (a → b) ↔ (a → c) :=
⟨fun hab ha => (h ha).1 (hab ha), fun hcd ha => (h ha).2 (hcd ha)⟩

theorem imp_congr_ctx (h₁ : a ↔ c) (h₂ : c → (b ↔ d)) : (a → b) ↔ (c → d) :=
(imp_congr_left h₁).trans (imp_congr_right h₂)

theorem imp_congr (h₁ : a ↔ c) (h₂ : b ↔ d) : (a → b) ↔ (c → d) := by
  aesop (safe [imp_congr_ctx])
  -- imp_congr_ctx h₁ fun _ => h₂

theorem Not.intro {a : Prop} (h : a → False) : ¬a := by aesop

-- TODO try False-elim with low priority if we have a hyp X → False in the
-- context.
def Not.elim (h : ¬a) (ha : a) : α := by aesop

theorem not_true : ¬True ↔ False := by aesop

theorem not_false_iff : ¬False ↔ True := by aesop

theorem not_congr (h : a ↔ b) : ¬a ↔ ¬b := by aesop

theorem ne_self_iff_false (a : α) : a ≠ a ↔ False := by aesop

theorem eq_self_iff_true (a : α) : a = a ↔ True := by aesop

theorem heq_self_iff_true (a : α) : a ≅ a ↔ True := iff_true_intro HEq.rfl

theorem iff_not_self : ¬(a ↔ ¬a) | H => let f h := H.1 h h; f (H.2 f)

theorem not_iff_self : ¬(¬a ↔ a) | H => iff_not_self H.symm

theorem eq_comm {a b : α} : a = b ↔ b = a := ⟨Eq.symm, Eq.symm⟩

theorem And.imp (f : a → c) (g : b → d) (h : a ∧ b) : c ∧ d := ⟨f h.1, g h.2⟩

theorem and_congr (h₁ : a ↔ c) (h₂ : b ↔ d) : a ∧ b ↔ c ∧ d := ⟨And.imp h₁.1 h₂.1, And.imp h₁.2 h₂.2⟩

theorem and_congr_right (h : a → (b ↔ c)) : (a ∧ b) ↔ (a ∧ c) :=
⟨fun ⟨ha, hb⟩ => ⟨ha, (h ha).1 hb⟩, fun ⟨ha, hb⟩ => ⟨ha, (h ha).2 hb⟩⟩

theorem and_comm : a ∧ b ↔ b ∧ a := ⟨And.symm, And.symm⟩

theorem and_assoc : (a ∧ b) ∧ c ↔ a ∧ (b ∧ c) :=
⟨fun ⟨⟨ha, hb⟩, hc⟩ => ⟨ha, hb, hc⟩, fun ⟨ha, hb, hc⟩ => ⟨⟨ha, hb⟩, hc⟩⟩

theorem and_left_comm : a ∧ (b ∧ c) ↔ b ∧ (a ∧ c) := by
  rw [← and_assoc, ← and_assoc, @and_comm a b]
  exact Iff.rfl

theorem and_iff_left (hb : b) : a ∧ b ↔ a := ⟨And.left, fun ha => ⟨ha, hb⟩⟩

theorem and_iff_right (ha : a) : a ∧ b ↔ b := ⟨And.right, fun hb => ⟨ha, hb⟩⟩

theorem and_true : a ∧ True ↔ a := and_iff_left ⟨⟩

theorem true_and : True ∧ a ↔ a := and_iff_right ⟨⟩

theorem and_false : a ∧ False ↔ False := iff_false_intro And.right

theorem false_and : False ∧ a ↔ False := iff_false_intro And.left

theorem and_not_self : ¬(a ∧ ¬a) | ⟨ha, hn⟩ => hn ha
theorem not_and_self : ¬(¬a ∧ a) | ⟨hn, ha⟩ => hn ha

theorem and_self : a ∧ a ↔ a := ⟨And.left, fun h => ⟨h, h⟩⟩

theorem Or.imp (f : a → c) (g : b → d) (h : a ∨ b) : c ∨ d := h.elim (inl ∘ f) (inr ∘ g)

theorem Or.imp_left (f : a → b) : a ∨ c → b ∨ c := Or.imp f id

theorem Or.imp_right (f : b → c) : a ∨ b → a ∨ c := Or.imp id f

theorem or_congr (h₁ : a ↔ c) (h₂ : b ↔ d) : (a ∨ b) ↔ (c ∨ d) :=
⟨Or.imp h₁.1 h₂.1, Or.imp h₁.2 h₂.2⟩

theorem or_comm : a ∨ b ↔ b ∨ a := ⟨Or.symm, Or.symm⟩

theorem Or.resolve_left (h : a ∨ b) (na : ¬a) : b := h.elim na.elim id

theorem Or.neg_resolve_left (h : ¬a ∨ b) (ha : a) : b := h.elim (absurd ha) id

theorem Or.resolve_right (h : a ∨ b) (nb : ¬b) : a := h.elim id nb.elim

theorem Or.neg_resolve_right (h : a ∨ ¬b) (nb : b) : a := h.elim id (absurd nb)

open Or in
theorem or_assoc {a b c} : (a ∨ b) ∨ c ↔ a ∨ (b ∨ c) :=
⟨fun | inl (inl h) => inl h
     | inl (inr h) => inr (inl h)
     | inr h => inr (inr h),
 fun | inl h => inl (inl h)
     | inr (inl h) => inl (inr h)
     | inr (inr h) => inr h⟩

theorem or_left_comm : a ∨ (b ∨ c) ↔ b ∨ (a ∨ c) := by
  rw [← or_assoc, ← or_assoc, @or_comm a b]
  exact Iff.rfl

theorem or_true : a ∨ True ↔ True := iff_true_intro (Or.inr ⟨⟩)

theorem true_or : True ∨ a ↔ True := iff_true_intro (Or.inl ⟨⟩)

theorem or_false : a ∨ False ↔ a := ⟨fun h => h.resolve_right id, Or.inl⟩

theorem false_or : False ∨ a ↔ a := ⟨fun h => h.resolve_left id, Or.inr⟩

theorem or_self : a ∨ a ↔ a := ⟨fun h => h.elim id id, Or.inl⟩

theorem not_or_intro : (na : ¬a) → (nb : ¬b) → ¬(a ∨ b) := Or.elim

theorem not_or (p q) : ¬ (p ∨ q) ↔ ¬ p ∧ ¬ q :=
⟨fun H => ⟨mt Or.inl H, mt Or.inr H⟩, fun ⟨hp, hq⟩ pq => pq.elim hp hq⟩

@[simp] theorem iff_true : (a ↔ True) ↔ a := ⟨fun h => h.2 ⟨⟩, iff_true_intro⟩

@[simp] theorem true_iff : (True ↔ a) ↔ a := iff_comm.trans iff_true

@[simp] theorem iff_false : (a ↔ False) ↔ ¬a := ⟨Iff.mp, iff_false_intro⟩

@[simp] theorem false_iff : (False ↔ a) ↔ ¬a := iff_comm.trans iff_false

@[simp] theorem iff_self : (a ↔ a) ↔ True := iff_true_intro Iff.rfl

theorem iff_congr (h₁ : a ↔ c) (h₂ : b ↔ d) : (a ↔ b) ↔ (c ↔ d) :=
⟨fun h => h₁.symm.trans $ h.trans h₂, fun h => h₁.trans $ h.trans h₂.symm⟩

@[simp] theorem imp_true_iff : (α → True) ↔ True := iff_true_intro fun _ => ⟨⟩

@[simp] theorem false_imp_iff : (False → a) ↔ True := iff_true_intro False.elim

def ExistsUnique (p : α → Prop) := ∃ x, p x ∧ ∀ y, p y → y = x

open Lean in
macro "∃! " xs:explicitBinders ", " b:term : term => expandExplicitBinders ``ExistsUnique xs b

theorem ExistsUnique.intro {p : α → Prop} (w : α)
  (h₁ : p w) (h₂ : ∀ y, p y → y = w) : ∃! x, p x := ⟨w, h₁, h₂⟩

theorem ExistsUnique.exists {p : α → Prop} : (∃! x, p x) → ∃ x, p x | ⟨x, h, _⟩ => ⟨x, h⟩

theorem ExistsUnique.unique {p : α → Prop} (h : ∃! x, p x)
  {y₁ y₂ : α} (py₁ : p y₁) (py₂ : p y₂) : y₁ = y₂ :=
let ⟨x, hx, hy⟩ := h; (hy _ py₁).trans (hy _ py₂).symm

theorem forall_congr {p q : α → Prop} (h : ∀ a, p a ↔ q a) : (∀ a, p a) ↔ ∀ a, q a :=
⟨fun H a => (h a).1 (H a), fun H a => (h a).2 (H a)⟩

theorem Exists.imp {p q : α → Prop} (h : ∀ a, p a → q a) : (∃ a, p a) → ∃ a, q a
| ⟨a, ha⟩ => ⟨a, h a ha⟩

theorem exists_congr {p q : α → Prop} (h : ∀ a, p a ↔ q a) : (∃ a, p a) ↔ ∃ a, q a :=
⟨Exists.imp fun x => (h x).1, Exists.imp fun x => (h x).2⟩

theorem exists_unique_congr {p q : α → Prop} (h : ∀ a, p a ↔ q a) : (∃! a, p a) ↔ ∃! a, q a :=
exists_congr fun x => and_congr (h _) $ forall_congr fun y => imp_congr_left (h _)

theorem forall_not_of_not_exists {p : α → Prop} (hne : ¬∃ x, p x) (x) : ¬p x | hp => hne ⟨x, hp⟩

instance forall_prop_decidable {p} (P : p → Prop)
  [Dp : Decidable p] [DP : ∀ h, Decidable (P h)] : Decidable (∀ h, P h) :=
  if h : p
  then decidableOfDecidableOfIff (DP h) ⟨λ h2 _ => h2, λ al => al h⟩
  else isTrue (λ h2 => absurd h2 h)

@[simp] theorem forall_eq {p : α → Prop} {a' : α} : (∀a, a = a' → p a) ↔ p a' :=
⟨λ h => h a' rfl, λ h a e => e.symm ▸ h⟩

theorem forall_and_distrib {p q : α → Prop} : (∀ x, p x ∧ q x) ↔ (∀ x, p x) ∧ (∀ x, q x) :=
⟨λ h => ⟨λ x => (h x).left, λ x => (h x).right⟩, λ ⟨h₁, h₂⟩ x => ⟨h₁ x, h₂ x⟩⟩

def Decidable.by_cases := @byCases
def Decidable.by_contradiction := @byContradiction
def Decidable.of_not_not := @ofNotNot

theorem Decidable.not_and [Decidable p] [Decidable q] : ¬ (p ∧ q) ↔ ¬ p ∨ ¬ q := notAndIffOrNot _ _

@[inline] def Or.by_cases [Decidable p] (h : p ∨ q) (h₁ : p → α) (h₂ : q → α) : α :=
if hp : p then h₁ hp else h₂ (h.resolve_left hp)

@[inline] def Or.by_cases' [Decidable q] (h : p ∨ q) (h₁ : p → α) (h₂ : q → α) : α :=
if hq : q then h₂ hq else h₁ (h.resolve_right hq)

theorem Exists.nonempty {p : α → Prop} : (∃ x, p x) → Nonempty α | ⟨x, _⟩ => ⟨x⟩

@[simp] def if_pos := @ifPos
@[simp] def if_neg := @ifNeg
@[simp] def dif_pos := @difPos
@[simp] def dif_neg := @difNeg

theorem ite_id [h : Decidable c] {α} (t : α) : (if c then t else t) = t := by cases h <;> rfl

@[simp] theorem if_true {h : Decidable True} (t e : α) : (@ite α True h t e) = t :=
if_pos trivial

@[simp] theorem if_false {h : Decidable False} (t e : α) : (@ite α False h t e) = e :=
if_neg not_false

theorem dif_eq_if [h : Decidable c] {α} (t : α) (e : α) : (if h : c then t else e) = ite c t e :=
by cases h <;> rfl

/-- Universe lifting operation -/
structure ulift.{r, s} (α : Type s) : Type (max s r) :=
up :: (down : α)

namespace ulift
/- Bijection between α and ulift.{v} α -/
theorem up_down {α : Type u} : ∀ (b : ulift.{v} α), up (down b) = b
| up a => rfl

theorem down_up {α : Type u} (a : α) : down (up.{v} a) = a := rfl
end ulift

/-- Universe lifting operation from Sort to Type -/
structure plift (α : Sort u) : Type u :=
up :: (down : α)

namespace plift
/- Bijection between α and plift α -/
theorem up_down : ∀ (b : plift α), up (down b) = b
| (up a) => rfl

theorem down_up (a : α) : down (up a) = a := rfl
end plift

namespace WellFounded

variable {α : Sort u} {C : α → Sort v} {r : α → α → Prop}

unsafe def fix'.impl (hwf : WellFounded r) (F : ∀ x, (∀ y, r y x → C y) → C x) (x : α) : C x :=
  F x fun y _ => impl hwf F y

set_option codegen false in
@[implementedBy fix'.impl]
def fix' (hwf : WellFounded r) (F : ∀ x, (∀ y, r y x → C y) → C x) (x : α) : C x := hwf.fix F x

end WellFounded

-- Below are items ported from mathlib/src/logic/basic.lean

theorem iff_of_eq (e : a = b) : a ↔ b := e ▸ Iff.rfl

def decidable_of_iff (a : Prop) (h : a ↔ b) [D : Decidable a] : Decidable b :=
decidableOfDecidableOfIff D h

/-
Stuff from mathlib's logic/basic.lean.
TODO: import the whole thing.
-/

theorem or_imp_distrib : (a ∨ b → c) ↔ (a → c) ∧ (b → c) :=
⟨fun h => ⟨fun ha => h (Or.inl ha), fun hb => h (Or.inr hb)⟩,
  fun ⟨ha, hb⟩ => Or.rec ha hb⟩

@[simp] theorem and_imp : (a ∧ b → c) ↔ (a → b → c) :=
Iff.intro (λ h ha hb => h ⟨ha, hb⟩) (λ h ⟨ha, hb⟩ => h ha hb)

@[simp] theorem not_and : ¬ (a ∧ b) ↔ (a → ¬ b) := and_imp

@[simp] theorem exists_imp_distrib {p : α → Prop} : ((∃ x, p x) → b) ↔ ∀ x, p x → b :=
⟨λ h x hpx => h ⟨x, hpx⟩, λ h ⟨x, hpx⟩ => h x hpx⟩

@[simp] theorem exists_false : ¬ (∃a:α, False) := fun ⟨a, h⟩ => h

@[simp] theorem exists_and_distrib_left {q : Prop} {p : α → Prop} :
  (∃x, q ∧ p x) ↔ q ∧ (∃x, p x) :=
⟨λ ⟨x, hq, hp⟩ => ⟨hq, x, hp⟩, λ ⟨hq, x, hp⟩ => ⟨x, hq, hp⟩⟩

@[simp] theorem exists_and_distrib_right {q : Prop} {p : α → Prop} :
  (∃x, p x ∧ q) ↔ (∃x, p x) ∧ q :=
by simp [and_comm]

@[simp] theorem exists_eq {a' : α} : ∃ a, a = a' := ⟨_, rfl⟩

@[simp] theorem exists_eq' {a' : α} : ∃ a, a' = a := ⟨_, rfl⟩

@[simp] theorem exists_eq_left {p : α → Prop} {a' : α} : (∃ a, a = a' ∧ p a) ↔ p a' :=
⟨λ ⟨a, e, h⟩ => e ▸ h, λ h => ⟨_, rfl, h⟩⟩

@[simp] theorem exists_eq_right {p : α → Prop} {a' : α} : (∃ a, p a ∧ a = a') ↔ p a' :=
(exists_congr $ by exact λ a => and_comm).trans exists_eq_left

@[simp] theorem exists_eq_left' {p : α → Prop} {a' : α} : (∃ a, a' = a ∧ p a) ↔ p a' :=
by simp [@eq_comm _ a']

protected theorem decidable.not_imp_symm [Decidable a] (h : ¬a → b) (hb : ¬b) : a :=
Decidable.by_contradiction $ hb ∘ h

theorem not.decidable_imp_symm [Decidable a] : (¬a → b) → ¬b → a := decidable.not_imp_symm

theorem not_forall_of_exists_not {p : α → Prop} : (∃ x, ¬ p x) → ¬ ∀ x, p x
| ⟨x, hn⟩, h => hn (h x)

protected theorem Decidable.not_forall {p : α → Prop}
  [Decidable (∃ x, ¬ p x)] [∀ x, Decidable (p x)] : (¬ ∀ x, p x) ↔ ∃ x, ¬ p x :=
⟨not.decidable_imp_symm $ λ nx x => not.decidable_imp_symm (λ h => ⟨x, h⟩) nx,
 not_forall_of_exists_not⟩

@[simp] theorem not_exists {p : α → Prop} : (¬ ∃ x, p x) ↔ ∀ x, ¬ p x :=
exists_imp_distrib

open Classical

@[simp] theorem not_forall {p : α → Prop} : (¬ ∀ x, p x) ↔ ∃ x, ¬ p x := Decidable.not_forall


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.homology.homology

/-!
# Chain complexes supported in a single degree

We define `single V j c : V ⥤ homological_complex V c`,
which constructs complexes in `V` of shape `c`, supported in degree `j`.

Similarly `single₀ V : V ⥤ chain_complex V ℕ` is the special case for
`ℕ`-indexed chain complexes, with the object supported in degree `0`,
but with better definitional properties.

In `to_single₀_equiv` we characterize chain maps to a `ℕ`-indexed complex concentrated in degree 0;
they are equivalent to `{ f : C.X 0 ⟶ X // C.d 1 0 ≫ f = 0 }`.
(This is useful translating between a projective resolution and
an augmented exact complex of projectives.)
-/

noncomputable theory

open category_theory
open category_theory.limits

universes v u

variables (V : Type u) [category.{v} V] [has_zero_morphisms V] [has_zero_object V]

namespace homological_complex
variables {ι : Type*} [decidable_eq ι] (c : complex_shape ι)

local attribute [instance] has_zero_object.has_zero

/--
The functor `V ⥤ homological_complex V c` creating a chain complex supported in a single degree.

See also `chain_complex.single₀ : V ⥤ chain_complex V ℕ`,
which has better definitional properties,
if you are working with `ℕ`-indexed complexes.
-/
@[simps]
def single (j : ι) : V ⥤ homological_complex V c :=
{ obj := λ A,
  { X := λ i, if i = j then A else 0,
    d := λ i j, 0, },
  map := λ A B f,
  { f := λ i, if h : i = j then
      eq_to_hom (by { dsimp, rw if_pos h, }) ≫ f ≫ eq_to_hom (by { dsimp, rw if_pos h, })
    else
      0, },
  map_id' := λ A, begin
    ext,
    dsimp,
    split_ifs with h,
    { subst h, simp, },
    { rw if_neg h, simp, },
  end,
  map_comp' := λ A B C f g, begin
    ext,
    dsimp,
    split_ifs with h,
    { subst h, simp, },
    { simp, },
  end, }.

/--
The object in degree `j` of `(single V c h).obj A` is just `A`.
-/
@[simps]
def single_obj_X_self (j : ι) (A : V) : ((single V c j).obj A).X j ≅ A :=
eq_to_iso (by simp)

@[simp]
lemma single_map_f_self (j : ι) {A B : V} (f : A ⟶ B) :
  ((single V c j).map f).f j =
    (single_obj_X_self V c j A).hom ≫ f ≫ (single_obj_X_self V c j B).inv :=
by { simp, refl, }

instance (j : ι) : faithful (single V c j) :=
{ map_injective' := λ X Y f g w, begin
    have := congr_hom w j,
    dsimp at this,
    simp only [dif_pos] at this,
    rw [←is_iso.inv_comp_eq, inv_eq_to_hom, eq_to_hom_trans_assoc, eq_to_hom_refl, category.id_comp,
      ←is_iso.comp_inv_eq, category.assoc, inv_eq_to_hom, eq_to_hom_trans, eq_to_hom_refl,
      category.comp_id] at this,
    exact this,
  end, }

instance (j : ι) : full (single V c j) :=
{ preimage := λ X Y f, eq_to_hom (by simp) ≫ f.f j ≫ eq_to_hom (by simp),
  witness' := λ X Y f, begin
    ext i,
    dsimp,
    split_ifs,
    { subst h, simp, },
    { symmetry,
      apply zero_of_target_iso_zero,
      dsimp,
      rw [if_neg h], },
  end }

end homological_complex

open homological_complex

namespace chain_complex

local attribute [instance] has_zero_object.has_zero

/--
`chain_complex.single₀ V` is the embedding of `V` into `chain_complex V ℕ`
as chain complexes supported in degree 0.

This is naturally isomorphic to `single V _ 0`, but has better definitional properties.
-/
def single₀ : V ⥤ chain_complex V ℕ :=
{ obj := λ X,
  { X := λ n, match n with
    | 0 := X
    | (n+1) := 0
    end,
    d := λ i j, 0, },
  map := λ X Y f,
  { f := λ n, match n with
    | 0 := f
    | (n+1) := 0
    end, },
  map_id' := λ X, by { ext n, cases n, refl, dsimp, unfold_aux, simp, },
  map_comp' := λ X Y Z f g, by { ext n, cases n, refl, dsimp, unfold_aux, simp, } }

@[simp] lemma single₀_obj_X_0 (X : V) : ((single₀ V).obj X).X 0 = X := rfl
@[simp] lemma single₀_obj_X_succ (X : V) (n : ℕ) : ((single₀ V).obj X).X (n+1) = 0 := rfl
@[simp] lemma single₀_obj_X_d (X : V) (i j : ℕ) : ((single₀ V).obj X).d i j = 0 := rfl
@[simp]

section
variables [has_equalizers V] [has_cokernels V] [has_images V] [has_image_maps V]

/--
Sending objects to chain complexes supported at `0` then taking `0`-th homology
is the same as doing nothing.
-/
noncomputable
def homology_functor_0_single₀ : single₀ V ⋙ homology_functor V _ 0 ≅ (𝟭 V) :=
nat_iso.of_components (λ X, homology.congr _ _ (by simp) (by simp) ≪≫ homology_zero_zero)
  (λ X Y f, by { ext, dsimp [homology_functor], simp, })

/--
Sending objects to chain complexes supported at `0` then taking `(n+1)`-st homology
is the same as the zero functor.
-/
noncomputable
def homology_functor_succ_single₀ (n : ℕ) : single₀ V ⋙ homology_functor V _ (n+1) ≅ 0 :=
nat_iso.of_components (λ X, homology.congr _ _ (by simp) (by simp) ≪≫
    homology_zero_zero ≪≫ (functor.zero_obj _).iso_zero.symm)
  (λ X Y f, by { exact (functor.zero_obj _).eq_of_tgt _ _ })

end

variables {V}

/--
Morphisms from a `ℕ`-indexed chain complex `C`
to a single object chain complex with `X` concentrated in degree 0
are the same as morphisms `f : C.X 0 ⟶ X` such that `C.d 1 0 ≫ f = 0`.
-/
@[simps]
def to_single₀_equiv (C : chain_complex V ℕ) (X : V) :
  (C ⟶ (single₀ V).obj X) ≃ { f : C.X 0 ⟶ X // C.d 1 0 ≫ f = 0 } :=
{ to_fun := λ f, ⟨f.f 0, by { rw ←f.comm 1 0, simp, }⟩,
  inv_fun := λ f,
  { f := λ i, match i with
    | 0 := f.1
    | (n+1) := 0
    end,
    comm' := λ i j h, begin
      rcases i with _|_|i; cases j; unfold_aux; simp only [comp_zero, zero_comp, single₀_obj_X_d],
      { rw [C.shape, zero_comp], simp, },
      { exact f.2.symm, },
      { rw [C.shape, zero_comp], simp [i.succ_succ_ne_one.symm] },
    end, },
  left_inv := λ f, begin
    ext i,
    rcases i,
    { refl, },
    { ext, },
  end,
  right_inv := by tidy, }

@[ext]
lemma to_single₀_ext {C : chain_complex V ℕ} {X : V}
  (f g : (C ⟶ (single₀ V).obj X)) (h : f.f 0 = g.f 0) : f = g :=
(to_single₀_equiv C X).injective (by { ext, exact h, })

/--
Morphisms from a single object chain complex with `X` concentrated in degree 0
to a `ℕ`-indexed chain complex `C` are the same as morphisms `f : X → C.X`.
-/
@[simps]
def from_single₀_equiv (C : chain_complex V ℕ) (X : V) :
  ((single₀ V).obj X ⟶ C) ≃ (X ⟶ C.X 0) :=
{ to_fun := λ f, f.f 0,
  inv_fun := λ f,
  { f := λ i, match i with
    | 0 := f
    | (n+1) := 0
    end,
    comm' := λ i j h, begin
      cases i; cases j; unfold_aux;
      simp only [shape, complex_shape.down_rel, nat.one_ne_zero, not_false_iff,
        comp_zero, zero_comp, nat.succ_ne_zero, single₀_obj_X_d],
    end },
  left_inv := λ f, begin
    ext i,
    cases i,
    { refl, },
    { ext, },
  end,
  right_inv := λ g, rfl, }

variables (V)

/-- `single₀` is the same as `single V _ 0`. -/
def single₀_iso_single : single₀ V ≅ single V _ 0 :=
nat_iso.of_components
  (λ X,
  { hom := { f := λ i, by { cases i; simpa using 𝟙 _, } },
    inv := { f := λ i, by { cases i; simpa using 𝟙 _, } },
    hom_inv_id' := by { ext (_|i); { dsimp, simp, }, },
    inv_hom_id' := begin
      ext (_|i),
      { apply category.id_comp, },
      { apply has_zero_object.to_zero_ext, },
    end, })
  (λ X Y f, by { ext (_|i); { dsimp, simp, }, })

instance : faithful (single₀ V) := faithful.of_iso (single₀_iso_single V).symm
instance : full (single₀ V) := full.of_iso (single₀_iso_single V).symm

end chain_complex

namespace cochain_complex

local attribute [instance] has_zero_object.has_zero

/--
`cochain_complex.single₀ V` is the embedding of `V` into `cochain_complex V ℕ`
as cochain complexes supported in degree 0.

This is naturally isomorphic to `single V _ 0`, but has better definitional properties.
-/
def single₀ : V ⥤ cochain_complex V ℕ :=
{ obj := λ X,
  { X := λ n, match n with
    | 0 := X
    | (n+1) := 0
    end,
    d := λ i j, 0, },
  map := λ X Y f,
  { f := λ n, match n with
    | 0 := f
    | (n+1) := 0
    end, },
  map_id' := λ X, by { ext n, cases n, refl, dsimp, unfold_aux, simp, },
  map_comp' := λ X Y Z f g, by { ext n, cases n, refl, dsimp, unfold_aux, simp, } }

@[simp] lemma single₀_obj_X_0 (X : V) : ((single₀ V).obj X).X 0 = X := rfl
@[simp] lemma single₀_obj_X_succ (X : V) (n : ℕ) : ((single₀ V).obj X).X (n+1) = 0 := rfl
@[simp] lemma single₀_obj_X_d (X : V) (i j : ℕ) : ((single₀ V).obj X).d i j = 0 := rfl
@[simp] lemma single₀_obj_X_d_from (X : V) (j : ℕ) : ((single₀ V).obj X).d_from j = 0 :=
by { rw [d_from_eq ((single₀ V).obj X) rfl], simp, }
@[simp] lemma single₀_obj_X_d_to (X : V) (i : ℕ) : ((single₀ V).obj X).d_to i = 0 :=
begin
  cases i,
  { rw [d_to_eq_zero], simp, },
  { rw [d_to_eq ((single₀ V).obj X) rfl], simp, },
end
@[simp] lemma single₀_map_f_0 {X Y : V} (f : X ⟶ Y) : ((single₀ V).map f).f 0 = f := rfl
@[simp] lemma single₀_map_f_succ {X Y : V} (f : X ⟶ Y) (n : ℕ) :
  ((single₀ V).map f).f (n+1) = 0 := rfl

section
variables [has_equalizers V] [has_cokernels V] [has_images V] [has_image_maps V]

/--
Sending objects to cochain complexes supported at `0` then taking `0`-th homology
is the same as doing nothing.
-/
noncomputable
def homology_functor_0_single₀ : single₀ V ⋙ homology_functor V _ 0 ≅ (𝟭 V) :=
nat_iso.of_components (λ X, homology.congr _ _ (by simp) (by simp) ≪≫ homology_zero_zero)
  (λ X Y f, by { ext, dsimp [homology_functor], simp, })

/--
Sending objects to cochain complexes supported at `0` then taking `(n+1)`-st homology
is the same as the zero functor.
-/
noncomputable
def homology_functor_succ_single₀ (n : ℕ) : single₀ V ⋙ homology_functor V _ (n+1) ≅ 0 :=
nat_iso.of_components (λ X, homology.congr _ _ (by simp) (by simp) ≪≫
    homology_zero_zero ≪≫ (functor.zero_obj _).iso_zero.symm)
  (λ X Y f, by { exact (functor.zero_obj _).eq_of_tgt _ _ })

end

variables {V}

/--
Morphisms from a single object cochain complex with `X` concentrated in degree 0
to a `ℕ`-indexed cochain complex `C`
are the same as morphisms `f : X ⟶ C.X 0` such that `f ≫ C.d 0 1 = 0`.
-/
def from_single₀_equiv (C : cochain_complex V ℕ) (X : V) :
  ((single₀ V).obj X ⟶ C) ≃ { f : X ⟶ C.X 0 // f ≫ C.d 0 1 = 0 } :=
{ to_fun := λ f, ⟨f.f 0, by { rw f.comm 0 1, simp, }⟩,
  inv_fun := λ f,
  { f := λ i, match i with
    | 0 := f.1
    | (n+1) := 0
    end,
    comm' := λ i j h, begin
      rcases j with _|_|j; cases i; unfold_aux; simp only [comp_zero, zero_comp, single₀_obj_X_d],
      { convert comp_zero, rw [C.shape], simp, },
      { exact f.2, },
      { convert comp_zero, rw [C.shape], simp only [complex_shape.up_rel, zero_add],
        exact (nat.one_lt_succ_succ j).ne },
    end, },
  left_inv := λ f, begin
    ext i,
    rcases i,
    { refl, },
    { ext, },
  end,
  right_inv := by tidy, }

variables (V)

/-- `single₀` is the same as `single V _ 0`. -/
def single₀_iso_single : single₀ V ≅ single V _ 0 :=
nat_iso.of_components
  (λ X,
  { hom := { f := λ i, by { cases i; simpa using 𝟙 _, } },
    inv := { f := λ i, by { cases i; simpa using 𝟙 _, } },
    hom_inv_id' := by { ext (_|i); { dsimp, simp, }, },
    inv_hom_id' := begin
      ext (_|i),
      { apply category.id_comp, },
      { apply has_zero_object.to_zero_ext, },
    end, })
  (λ X Y f, by { ext (_|i); { dsimp, simp, }, })

instance : faithful (single₀ V) := faithful.of_iso (single₀_iso_single V).symm
instance : full (single₀ V) := full.of_iso (single₀_iso_single V).symm

end cochain_complex


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

import category_theory.comma
import category_theory.arrow
import category_theory.opposites
import category_theory.limits.shapes.binary_products

open category_theory
open category_theory.category
open category_theory.limits
open opposite

namespace category_theory

universes v₁ v₂ v₃ u₁ u₂ u₃
variables {A : Type u₁} [category.{v₁} A]
variables {B : Type u₂} [category.{v₂} B]
variables {T : Type u₃} [category.{v₃} T]

@[simps]
def functor_comma_op (L : A ⥤ T) (R : B ⥤ T) :
  (comma L R)ᵒᵖ ⥤ comma R.op L.op :=
{ obj := λ X,
  { left := op X.unop.right,
    right := op X.unop.left,
    hom := X.unop.hom.op, },
  map := λ X Y f,
  { left := f.unop.right.op,
    right := f.unop.left.op,
    w' := by { apply quiver.hom.unop_inj, exact f.unop.w'.symm, },  }, }

@[simps]
def functor_comma_unop (L : A ⥤ T) (R : B ⥤ T) :
  comma R.op L.op ⥤ (comma L R)ᵒᵖ :=
{ obj := λ X, op
  { left := X.right.unop,
    right := X.left.unop,
    hom := X.hom.unop, },
  map := λ X Y f, quiver.hom.op
  { left := f.right.unop,
    right := f.left.unop,
    w' := by { apply quiver.hom.op_inj, exact f.w'.symm, }, } }

@[simps]
def equivalence_comma_op (L : A ⥤ T) (R : B ⥤ T) :
  (comma L R)ᵒᵖ ≌ comma R.op L.op :=
{ functor := functor_comma_op L R,
  inverse := functor_comma_unop L R,
  unit_iso := eq_to_iso begin
    apply functor.ext,
    { intros X Y f,
      apply quiver.hom.unop_inj,
      apply comma_morphism.ext,
      tidy, },
    { intro X,
      rw ← op_unop X,
      generalize : X.unop = Y,
      cases Y,
      refl, }
  end,
  counit_iso := eq_to_iso begin
    apply functor.ext,
    { tidy, },
    { intro X,
      cases X,
      refl, }
  end,
  functor_unit_iso_comp' := by tidy, }

variable (T)
@[simps]
def equivalence_arrow_op :
  (arrow T)ᵒᵖ ≌ arrow Tᵒᵖ := equivalence_comma_op (𝟭 T) (𝟭 T)

variable {T}

namespace arrow

@[simp, protected]
def op (f : arrow T) : arrow Tᵒᵖ := ((equivalence_arrow_op T).functor.obj (op f))
@[simp, protected]
def unop (f : arrow Tᵒᵖ) : arrow T := ((equivalence_arrow_op T).inverse.obj f).unop

lemma unop_op (f : arrow T) : f.op.unop = f := by { cases f, refl, }
lemma op_unop (f : arrow Tᵒᵖ) : f.unop.op = f := by { cases f, refl, }

end arrow

/-#exit

lemma mk_eq (f : arrow T) : arrow.mk f.hom = f :=
by { cases f, dsimp [arrow.mk], refl, }

def op_hom {f g : arrow T} (sq : f ⟶ g) : g.op ⟶ f.op :=
((equivalence_arrow_op T).functor.map sq).unop

def unop_hom' {f g : arrow Tᵒᵖ} (sq : f ⟶ g) : g.unop ⟶ f.unop :=
((equivalence_arrow_op T).inverse.map sq.op)

def unop_hom {f g : arrow T} (sq : f.op ⟶ g.op) : g ⟶ f :=
eq_to_hom g.unop_op.symm ≫ unop_hom' sq ≫ eq_to_hom f.unop_op

def op_unop_hom {f g : arrow T} (sq : f.op ⟶ g.op) : sq = op_hom (unop_hom sq) :=
begin
  cases f,
  cases g,
  cases sq,
  dsimp only [unop_hom],
  erw [id_comp, comp_id],
  congr,
end

end arrow-/

end category_theory


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import tactic.elementwise
import category_theory.limits.shapes.multiequalizer
import category_theory.limits.constructions.epi_mono
import category_theory.limits.preserves.limits
import category_theory.limits.shapes.types

/-!
# Gluing data

We define `glue_data` as a family of data needed to glue topological spaces, schemes, etc. We
provide the API to realize it as a multispan diagram, and also states lemmas about its
interaction with a functor that preserves certain pullbacks.

-/

noncomputable theory

open category_theory.limits
namespace category_theory

universes v u₁ u₂

variables (C : Type u₁) [category.{v} C] {C' : Type u₂} [category.{v} C']

/--
A gluing datum consists of
1. An index type `J`
2. An object `U i` for each `i : J`.
3. An object `V i j` for each `i j : J`.
4. A monomorphism `f i j : V i j ⟶ U i` for each `i j : J`.
5. A transition map `t i j : V i j ⟶ V j i` for each `i j : J`.
such that
6. `f i i` is an isomorphism.
7. `t i i` is the identity.
8. The pullback for `f i j` and `f i k` exists.
9. `V i j ×[U i] V i k ⟶ V i j ⟶ V j i` factors through `V j k ×[U j] V j i ⟶ V j i` via some
    `t' : V i j ×[U i] V i k ⟶ V j k ×[U j] V j i`.
10. `t' i j k ≫ t' j k i ≫ t' k i j = 𝟙 _`.
-/
@[nolint has_inhabited_instance]
structure glue_data :=
(J : Type v)
(U : J → C)
(V : J × J → C)
(f : Π i j, V (i, j) ⟶ U i)
(f_mono : ∀ i j, mono (f i j) . tactic.apply_instance)
(f_has_pullback : ∀ i j k, has_pullback (f i j) (f i k) . tactic.apply_instance)
(f_id : ∀ i, is_iso (f i i) . tactic.apply_instance)
(t : Π i j, V (i, j) ⟶ V (j, i))
(t_id : ∀ i, t i i = 𝟙 _)
(t' : Π i j k, pullback (f i j) (f i k) ⟶ pullback (f j k) (f j i))
(t_fac : ∀ i j k, t' i j k ≫ pullback.snd = pullback.fst ≫ t i j)
(cocycle : ∀ i j k , t' i j k ≫ t' j k i ≫ t' k i j = 𝟙 _)

attribute [simp] glue_data.t_id
attribute [instance] glue_data.f_id glue_data.f_mono glue_data.f_has_pullback
attribute [reassoc] glue_data.t_fac glue_data.cocycle

namespace glue_data

variables {C} (D : glue_data C)

@[simp] lemma t'_iij (i j : D.J) : D.t' i i j = (pullback_symmetry _ _).hom :=
begin
  have eq₁ := D.t_fac i i j,
  have eq₂ := (is_iso.eq_comp_inv (D.f i i)).mpr (@pullback.condition _ _ _ _ _ _ (D.f i j) _),
  rw [D.t_id, category.comp_id, eq₂] at eq₁,
  have eq₃ := (is_iso.eq_comp_inv (D.f i i)).mp eq₁,
  rw [category.assoc, ←pullback.condition, ←category.assoc] at eq₃,
  exact mono.right_cancellation _ _
    ((mono.right_cancellation _ _ eq₃).trans (pullback_symmetry_hom_comp_fst _ _).symm)
end

lemma t'_jii (i j : D.J) : D.t' j i i = pullback.fst ≫ D.t j i ≫ inv pullback.snd :=
by { rw [←category.assoc, ←D.t_fac], simp }

lemma t'_iji (i j : D.J) : D.t' i j i = pullback.fst ≫ D.t i j ≫ inv pullback.snd :=
by { rw [←category.assoc, ←D.t_fac], simp }

@[simp, reassoc, elementwise] lemma t_inv (i j : D.J) :
  D.t i j ≫ D.t j i = 𝟙 _ :=
begin
  have eq : (pullback_symmetry (D.f i i) (D.f i j)).hom = pullback.snd ≫ inv pullback.fst,
  { simp },
  have := D.cocycle i j i,
  rw [D.t'_iij, D.t'_jii, D.t'_iji, fst_eq_snd_of_mono_eq, eq] at this,
  simp only [category.assoc, is_iso.inv_hom_id_assoc] at this,
  rw [←is_iso.eq_inv_comp, ←category.assoc, is_iso.comp_inv_eq] at this,
  simpa using this,
end

lemma t'_inv (i j k : D.J) : D.t' i j k ≫ (pullback_symmetry _ _).hom ≫
  D.t' j i k ≫ (pullback_symmetry _ _).hom = 𝟙 _ :=
begin
  rw ← cancel_mono (pullback.fst : pullback (D.f i j) (D.f i k) ⟶ _),
  simp [t_fac, t_fac_assoc]
end

instance t_is_iso (i j : D.J) : is_iso (D.t i j) :=
⟨⟨D.t j i, D.t_inv _ _, D.t_inv _ _⟩⟩

instance t'_is_iso (i j k : D.J) : is_iso (D.t' i j k) :=
⟨⟨D.t' j k i ≫ D.t' k i j, D.cocycle _ _ _, (by simpa using D.cocycle _ _ _)⟩⟩

@[reassoc]
lemma t'_comp_eq_pullback_symmetry (i j k : D.J) :
  D.t' j k i ≫ D.t' k i j = (pullback_symmetry _ _).hom ≫
  D.t' j i k ≫ (pullback_symmetry _ _).hom :=
begin
  transitivity inv (D.t' i j k),
  { exact is_iso.eq_inv_of_hom_inv_id (D.cocycle _ _ _) },
  { rw ← cancel_mono (pullback.fst : pullback (D.f i j) (D.f i k) ⟶ _),
    simp [t_fac, t_fac_assoc] }
end

/-- (Implementation) The disjoint union of `U i`. -/
def sigma_opens [has_coproduct D.U] : C := ∐ D.U

/-- (Implementation) The diagram to take colimit of. -/
def diagram : multispan_index C :=
{ L := D.J × D.J, R := D.J,
  fst_from := _root_.prod.fst, snd_from := _root_.prod.snd,
  left := D.V, right := D.U,
  fst := λ ⟨i, j⟩, D.f i j,
  snd := λ ⟨i, j⟩, D.t i j ≫ D.f j i }

@[simp] lemma diagram_L : D.diagram.L = (D.J × D.J) := rfl
@[simp] lemma diagram_R : D.diagram.R = D.J := rfl
@[simp] lemma diagram_fst_from (i j : D.J) : D.diagram.fst_from ⟨i, j⟩ = i := rfl
@[simp] lemma diagram_snd_from (i j : D.J) : D.diagram.snd_from ⟨i, j⟩ = j := rfl
@[simp] lemma diagram_fst (i j : D.J) : D.diagram.fst ⟨i, j⟩ = D.f i j := rfl
@[simp] lemma diagram_snd (i j : D.J) : D.diagram.snd ⟨i, j⟩ = D.t i j ≫ D.f j i := rfl
@[simp] lemma diagram_left : D.diagram.left = D.V := rfl
@[simp] lemma diagram_right : D.diagram.right = D.U := rfl

section

variable [has_multicoequalizer D.diagram]

/-- The glued object given a family of gluing data. -/
def glued : C := multicoequalizer D.diagram

/-- The map `D.U i ⟶ D.glued` for each `i`. -/
def ι (i : D.J) : D.U i ⟶ D.glued :=
multicoequalizer.π D.diagram i

@[simp, elementwise]
lemma glue_condition (i j : D.J) :
  D.t i j ≫ D.f j i ≫ D.ι j = D.f i j ≫ D.ι i :=
(category.assoc _ _ _).symm.trans (multicoequalizer.condition D.diagram ⟨i, j⟩).symm

/-- The pullback cone spanned by `V i j ⟶ U i` and `V i j ⟶ U j`.
This will often be a pullback diagram. -/
 def V_pullback_cone (i j : D.J) : pullback_cone (D.ι i) (D.ι j) :=
 pullback_cone.mk (D.f i j) (D.t i j ≫ D.f j i) (by simp)

variables [has_colimits C]

/-- The projection `∐ D.U ⟶ D.glued` given by the colimit. -/
def π : D.sigma_opens ⟶ D.glued := multicoequalizer.sigma_π D.diagram

instance π_epi : epi D.π := by { unfold π, apply_instance }

end

lemma types_π_surjective (D : glue_data Type*) :
  function.surjective D.π := (epi_iff_surjective _).mp infer_instance

lemma types_ι_jointly_surjective (D : glue_data Type*) (x : D.glued) :
  ∃ i (y : D.U i), D.ι i y = x :=
begin
  delta category_theory.glue_data.ι,
  simp_rw ← multicoequalizer.ι_sigma_π D.diagram,
  rcases D.types_π_surjective x with ⟨x', rfl⟩,
  have := colimit.iso_colimit_cocone (types.coproduct_colimit_cocone _),
  rw ← (show (colimit.iso_colimit_cocone (types.coproduct_colimit_cocone _)).inv _ = x',
    from concrete_category.congr_hom
      ((colimit.iso_colimit_cocone (types.coproduct_colimit_cocone _)).hom_inv_id) x'),
  rcases (colimit.iso_colimit_cocone (types.coproduct_colimit_cocone _)).hom x' with ⟨i, y⟩,
  exact ⟨i, y, by { simpa [← multicoequalizer.ι_sigma_π, -multicoequalizer.ι_sigma_π] }⟩
end

variables (F : C ⥤ C') [H : ∀ i j k, preserves_limit (cospan (D.f i j) (D.f i k)) F]

include H

instance (i j k : D.J) : has_pullback (F.map (D.f i j)) (F.map (D.f i k)) :=
⟨⟨⟨_, is_limit_of_has_pullback_of_preserves_limit F (D.f i j) (D.f i k)⟩⟩⟩

/-- A functor that preserves the pullbacks of `f i j` and `f i k` can map a family of glue data. -/
@[simps] def map_glue_data :
  glue_data C' :=
{ J := D.J,
  U := λ i, F.obj (D.U i),
  V := λ i, F.obj (D.V i),
  f := λ i j, F.map (D.f i j),
  f_mono := λ i j, category_theory.preserves_mono F (D.f i j),
  f_id := λ i, infer_instance,
  t := λ i j, F.map (D.t i j),
  t_id := λ i, by { rw D.t_id i, simp },
  t' := λ i j k, (preserves_pullback.iso F (D.f i j) (D.f i k)).inv ≫
    F.map (D.t' i j k) ≫ (preserves_pullback.iso F (D.f j k) (D.f j i)).hom,
  t_fac := λ i j k, by simpa [iso.inv_comp_eq] using congr_arg (λ f, F.map f) (D.t_fac i j k),
  cocycle := λ i j k, by simp only [category.assoc, iso.hom_inv_id_assoc, ← functor.map_comp_assoc,
    D.cocycle, iso.inv_hom_id, category_theory.functor.map_id, category.id_comp] }

/--
The diagram of the image of a `glue_data` under a functor `F` is naturally isomorphic to the
original diagram of the `glue_data` via `F`.
-/
def diagram_iso : D.diagram.multispan ⋙ F ≅ (D.map_glue_data F).diagram.multispan :=
nat_iso.of_components
  (λ x, match x with
    | walking_multispan.left a := iso.refl _
    | walking_multispan.right b := iso.refl _
    end)
  (begin
    rintros (⟨_,_⟩|_) _ (_|_|_),
    { erw [category.comp_id, category.id_comp, functor.map_id], refl },
    { erw [category.comp_id, category.id_comp], refl },
    { erw [category.comp_id, category.id_comp, functor.map_comp], refl },
    { erw [category.comp_id, category.id_comp, functor.map_id], refl },
  end)

@[simp] lemma diagram_iso_app_left (i : D.J × D.J) :
  (D.diagram_iso F).app (walking_multispan.left i) = iso.refl _ := rfl

@[simp]

@[simp] lemma diagram_iso_hom_app_left (i : D.J × D.J) :
  (D.diagram_iso F).hom.app (walking_multispan.left i) = 𝟙 _ := rfl

@[simp] lemma diagram_iso_hom_app_right (i : D.J) :
  (D.diagram_iso F).hom.app (walking_multispan.right i) = 𝟙 _ := rfl

@[simp] lemma diagram_iso_inv_app_left (i : D.J × D.J) :
  (D.diagram_iso F).inv.app (walking_multispan.left i) = 𝟙 _ := rfl

@[simp] lemma diagram_iso_inv_app_right (i : D.J) :
  (D.diagram_iso F).inv.app (walking_multispan.right i) = 𝟙 _ := rfl

variables [has_multicoequalizer D.diagram] [preserves_colimit D.diagram.multispan F]

omit H

lemma has_colimit_multispan_comp : has_colimit (D.diagram.multispan ⋙ F) :=
⟨⟨⟨_,preserves_colimit.preserves (colimit.is_colimit _)⟩⟩⟩

include H

local attribute [instance] has_colimit_multispan_comp

lemma has_colimit_map_glue_data_diagram : has_multicoequalizer (D.map_glue_data F).diagram :=
has_colimit_of_iso (D.diagram_iso F).symm

local attribute [instance] has_colimit_map_glue_data_diagram

/-- If `F` preserves the gluing, we obtain an iso between the glued objects. -/
def glued_iso : F.obj D.glued ≅ (D.map_glue_data F).glued :=
preserves_colimit_iso F D.diagram.multispan ≪≫
  (limits.has_colimit.iso_of_nat_iso (D.diagram_iso F))

@[simp, reassoc]
lemma ι_glued_iso_hom (i : D.J) :
  F.map (D.ι i) ≫ (D.glued_iso F).hom = (D.map_glue_data F).ι i :=
by { erw ι_preserves_colimits_iso_hom_assoc, rw has_colimit.iso_of_nat_iso_ι_hom,
  erw category.id_comp, refl }

@[simp, reassoc]
lemma ι_glued_iso_inv (i : D.J) :
  (D.map_glue_data F).ι i ≫ (D.glued_iso F).inv = F.map (D.ι i) :=
by rw [iso.comp_inv_eq, ι_glued_iso_hom]

/-- If `F` preserves the gluing, and reflects the pullback of `U i ⟶ glued` and `U j ⟶ glued`,
then `F` reflects the fact that `V_pullback_cone` is a pullback. -/
def V_pullback_cone_is_limit_of_map (i j : D.J) [reflects_limit (cospan (D.ι i) (D.ι j)) F]
  (hc : is_limit ((D.map_glue_data F).V_pullback_cone i j)) :
  is_limit (D.V_pullback_cone i j) :=
begin
  apply is_limit_of_reflects F,
  apply (is_limit_map_cone_pullback_cone_equiv _ _).symm _,
  let e : cospan (F.map (D.ι i)) (F.map (D.ι j)) ≅
    cospan ((D.map_glue_data F).ι i) ((D.map_glue_data F).ι j),
  exact nat_iso.of_components
    (λ x, by { cases x, exacts [D.glued_iso F, iso.refl _] })
    (by rintros (_|_) (_|_) (_|_|_); simp),
  apply is_limit.postcompose_hom_equiv e _ _,
  apply hc.of_iso_limit,
  refine cones.ext (iso.refl _) _,
  { rintro (_|_|_),
    change _ = _ ≫ (_ ≫ _) ≫ _,
    all_goals { change _ = 𝟙 _ ≫ _ ≫ _, simpa } }
end

omit H

/-- If there is a forgetful functor into `Type` that preserves enough (co)limits, then `D.ι` will
be jointly surjective. -/
lemma ι_jointly_surjective (F : C ⥤ Type v) [preserves_colimit D.diagram.multispan F]
  [Π (i j k : D.J), preserves_limit (cospan (D.f i j) (D.f i k)) F] (x : F.obj (D.glued)) :
  ∃ i (y : F.obj (D.U i)), F.map (D.ι i) y = x :=
begin
  let e := D.glued_iso F,
  obtain ⟨i, y, eq⟩ := (D.map_glue_data F).types_ι_jointly_surjective (e.hom x),
  replace eq := congr_arg e.inv eq,
  change ((D.map_glue_data F).ι i ≫ e.inv) y = (e.hom ≫ e.inv) x at eq,
  rw [e.hom_inv_id, D.ι_glued_iso_inv] at eq,
  exact ⟨i, y, eq⟩
end

end glue_data

end category_theory


/-
Copyright (c) 2017 Daniel Selsam. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Daniel Selsam

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

namespace Tactic

unsafe def apply_congr_core (clemma : congr_lemma) : tactic Unit := do
  assert `H_congr_lemma clemma
  exact clemma
  get_local `H_congr_lemma >>= apply
  all_goals' do
      try (applyc `heq_of_eq)
      get_local `H_congr_lemma >>= clear
#align tactic.apply_congr_core tactic.apply_congr_core

unsafe def apply_eq_congr_core (tgt : expr) : tactic Unit := do
  let (lhs, rhs) ← match_eq tgt
  guard lhs
  let clemma ← mk_specialized_congr_lemma lhs
  apply_congr_core clemma
#align tactic.apply_eq_congr_core tactic.apply_eq_congr_core

unsafe def apply_heq_congr_core : tactic Unit := do
  try (applyc `eq_of_heq)
  let (α, lhs, β, rhs) ← target >>= match_heq
  guard lhs
  let clemma ← mk_hcongr_lemma lhs.get_app_fn lhs.get_app_num_args
  apply_congr_core clemma
#align tactic.apply_heq_congr_core tactic.apply_heq_congr_core

unsafe def congr_core : tactic Unit := do
  let tgt ← target
  apply_eq_congr_core tgt <|> apply_heq_congr_core <|> fail "congr tactic failed"
#align tactic.congr_core tactic.congr_core

unsafe def congr : tactic Unit := do
  focus1 ((try assumption >> congr_core) >> all_goals' (try reflexivity >> try congr))
#align tactic.congr tactic.congr

end Tactic


import basic.conventional basic.non_comm

variables (G : Type) [gyrogroup G]
variables (a b c d : G)

namespace gyrogroup

@[simp] lemma gyro_equal : b = c → a ⊙ b = a ⊙ c :=
begin
  intros fbc,
  rw fbc,
end

end gyrogroup


import
  .lemmas.substitution
  .lemmas.big_step

open env_big_step

lemma big_subst_sound {E e S r} :
    big_subst E e ⟹ r
  → (E, compile e, S) ⟹ₙᵥ (E, r :: S) :=
begin
  assume h,
  induction' e,
  case EVal {
    rw compile,
    rw big_subst_val at h,
    cases' h,
    apply ERunPush,
    apply ERunEmpty
  },
  case EVar {
    rw compile,
    cases' big_subst_var_implies_bound h with v hbound,
    apply ERunLookup hbound,
    rw big_subst_bound_var hbound h,
    exact ERunEmpty
  },
  case EOp {
    rw compile, simp,
    rw big_subst_spread_op at h,
    cases' h,
    apply from_interm_results' (ih_e_1 h_1),
    apply from_interm_results' (ih_e h),
    apply ERunOpInstr,
    apply ERunEmpty
  },
  case EIf {
    rw compile, simp,
    rw big_subst_spread_if at h,
    cases' h,
    case RunIfT {
      apply from_interm_results' (ih_e h),
      apply ERunTBranch,
      apply from_interm_results' (ih_e_1 h_1),
      apply ERunJump,
      exact at_least_refl,
      rw list.drop_length,
      apply ERunEmpty
    },
    case RunIfF {
      apply from_interm_results' (ih_e h),
      apply ERunFBranch,
      { rw [at_least], simp },
      rw [nat.add_comm,
          list.drop_add,
          list.drop_one,
          list.drop_append_of_le_length,
          list.drop_length,
          list.nil_append,
          list.tail],
      exact ih_e_2 h_1,
      refl
    }
  },
  case ELet {
    rw compile, simp,
    rw big_subst_spread_let at h,
    cases' h,
    apply from_interm_results' (ih_e h),
    apply ERunOpenScope,
    rw [subst_merge,
      big_subst_remove_append] at h_1,
    apply from_interm_results' (ih_e_1 h_1),
    apply ERunCloseScope,
    apply ERunEmpty
  }
end

theorem compile_sound_nv {e : exp} {v : val} :
    e ⟹ v
  → ([], compile e, []) ⟹ₙᵥ ([], [v]) :=
λ h, big_subst_sound $ eq.subst (big_subst_empty e) h

theorem compile_sound (e : exp) (v : val) :
    e ⟹ v
  → ([], compile e, []) ⟹ᵥₘ [v] :=
env_vm_big_step ∘ compile_sound_nv


import .fairness

universe variables u u₀ u₁ u₂

namespace temporal

open predicate fairness

variables {α : Type u}

structure mch' (evt : Type u₀) (α : Type u) :=
  (init : pred' α)
  (cs fs : evt → pred' α)
  (A : option evt → act α)

namespace mch'

variable {evt : Type u₀}
variables (m : mch' evt α)
local notation `cs` := m.cs
local notation `fs` := m.fs
local notation `p` := m.init
local notation `A` := m.A

def effect : option evt → α → α → Prop
 | none v v' := A none v v'
 | (some e) v v' := v ⊨ cs e ∧ v ⊨ fs e ⋀ A (some e) v v'

local notation `Next` := m.effect

protected def event (e : evt) : event α :=
⟨ cs e, fs e, A e ⟩

def event' (aevt : Type u₀) (e : evt) (e' : aevt) : event (α × evt × aevt) :=
⟨ cs e ! pair.fst
, fs e ! pair.fst
, λ ⟨s,ce,_⟩ ⟨s',_,ae'⟩, ae' = e' ∧ ce = e ∧ A e s s' ⟩

-- abbreviation ce' (i : cevt) (j : aevt) : event (γ×β×(cevt×aevt)) :=
-- { p := cs₁ i!⟨prod.map_right fst⟩
-- , q := fs₁ i!⟨prod.map_right fst⟩
-- , A := λ ⟨o,v,ce,_⟩ ⟨o',v',_,ae'⟩, ae' = j ∧ ce = i ∧ C i (o,v) (o',v') }

@[simp, tl_simp]
def spec_saf_spec (v : tvar α) (sch : tvar evt) : cpred :=
p ! v ⋀
◻(∃∃ e, ⟦ v | m.effect e ⟧ )

@[simp, tl_simp]
def spec (v : tvar α) : cpred :=
p ! v ⋀
◻(∃∃ e, ⟦ v | m.effect e ⟧ ) ⋀
∀∀ e, sched (cs e ! v) (fs e ! v) ⟦ v | A e ⟧

@[simp, tl_simp]
def spec_sch (v : tvar α) (sch : tvar (option evt)) : cpred :=
p ! v ⋀
◻(∃∃ e : option evt, sch ≃ ↑e ⋀ ⟦ v | m.effect e ⟧) ⋀
∀∀ e : evt, sched (cs e ! v) (fs e ! v) (sch ≃ some e ⋀ ⟦ v | A ↑e ⟧)

structure invariant (J : pred' α) : Prop :=
  (init : p ⟹ J)
  (step : ∀ e s s', Next e s s' → s ⊨ J → s' ⊨ J)

end mch'

structure mch (α : Type u) :=
  {evt : Type u₀}
  (init : pred' α)
  (cs fs : evt → pred' α)
  (A : option evt → act α)

namespace mch
variables (m : mch α)
local notation `evt` := m.evt
local notation `cs` := m.cs
local notation `fs` := m.fs
local notation `p` := m.init
local notation `A` := m.A

def effect : option evt → α → α → Prop
 | none v v' := A none v v'
 | (some e) v v' := v ⊨ cs e ∧ v ⊨ fs e ⋀ A (some e) v v'

local notation `Next` := m.effect

lemma act_of_effect {v v' : α} {e : option evt}
  (h : Next e v v')
: A e v v' :=
by { cases e ; revert h ; simp [effect], }

protected def event (e : evt) : event α :=
⟨ cs e, fs e, A e ⟩

def event' (aevt : Type u₀) (e : evt) (e' : aevt) : event (α × option evt × aevt) :=
⟨ cs e ! pair.fst
, fs e ! pair.fst
, λ ⟨s,ce,_⟩ ⟨s',_,ae'⟩, ae' = e' ∧ ce = e ∧ A e s s' ⟩

-- abbreviation ce' (i : cevt) (j : aevt) : event (γ×β×(cevt×aevt)) :=
-- { p := cs₁ i!⟨prod.map_right fst⟩
-- , q := fs₁ i!⟨prod.map_right fst⟩
-- , A := λ ⟨o,v,ce,_⟩ ⟨o',v',_,ae'⟩, ae' = j ∧ ce = i ∧ C i (o,v) (o',v') }

@[simp, tl_simp]
def spec_saf_sch (v : tvar α) (sch : tvar (option evt)) : cpred :=
p ! v ⋀
◻(∃∃ e : option evt, sch ≃ ↑e ⋀ ⟦ v | m.effect e ⟧)

@[simp, tl_simp]
def spec (v : tvar α) : cpred :=
p ! v ⋀
◻(∃∃ e, ⟦ v | m.effect e ⟧ ) ⋀
∀∀ e, sched (cs e ! v) (fs e ! v) ⟦ v | A e ⟧

@[simp, tl_simp]
def spec_sch (v : tvar α) (sch : tvar (option evt)) : cpred :=
p ! v ⋀
◻(∃∃ e : option evt, sch ≃ ↑e ⋀ ⟦ v | m.effect e ⟧) ⋀
∀∀ e : evt, sched (cs e ! v) (fs e ! v) (sch ≃ some e ⋀ ⟦ v | A e ⟧)

structure invariant (J : pred' α) : Prop :=
  (init : p ⟹ J)
  (step : ∀ e s s', Next e s s' → s ⊨ J → s' ⊨ J)

variable {Γ : cpred}

lemma spec_sch_of_spec_saf_sch (v : tvar α) (sch : tvar (option evt))
  (h : Γ ⊢ m.spec_saf_sch v sch)
  (h' : Γ ⊢ ∀∀ (e : m.evt), sched (m.cs e ! v) (m.fs e ! v) (sch ≃ ↑(some e) ⋀ ⟦ v | m.A (some e) ⟧))
: Γ ⊢ m.spec_sch v sch :=
begin [temporal]
  simp at *,
  split ; assumption,
end

lemma spec_of_spec_sch (v : tvar α) (sch : tvar (option evt))
  (h : Γ ⊢ m.spec_sch v sch)
: Γ ⊢ m.spec v :=
begin [temporal]
  simp at *,
  revert h,
  apply ctx_p_and_p_imp_p_and',
  apply ctx_p_and_p_imp_p_and_right',
  { monotonicity, apply p_exists_p_imp_p_exists,
    simp, },
  { apply p_forall_p_imp_p_forall,
    intro, apply sched_imp_sched, simp },
end

lemma spec_of_spec_saf_sch (v : tvar α) (sch : tvar (option evt))
  (h : Γ ⊢ m.spec_saf_sch v sch)
  (h' : Γ ⊢ ∀∀ (e : m.evt), sched (m.cs e ! v) (m.fs e ! v) ⟦ v | m.A (some e) ⟧)
: Γ ⊢ m.spec v :=
begin [temporal]
  simp at *,
  split,
  { revert h,
    apply ctx_p_and_p_imp_p_and_right',
    monotonicity,
    apply p_exists_p_imp_p_exists,
    simp  },
  assumption,
end

end mch

end temporal


def foo := @id
def bar := @id
theorem foo_eq {α} (x : α) : foo x = bar x := rfl
example {p : Nat → Prop} {x} (h : x = bar 1) : p x := by
  simp [*, ← foo_eq]
  show p (foo 1)
  admit


import pseudo_normed_group.category.strictCompHausFiltPseuNormGrp

universe variables u

open category_theory
open_locale nnreal

noncomputable theory

local attribute [instance] type_pow

/-- The category of profinitely filtered pseudo-normed groups. -/
def ProFiltPseuNormGrp : Type (u+1) :=
bundled profinitely_filtered_pseudo_normed_group

namespace ProFiltPseuNormGrp

local attribute [instance] CompHausFiltPseuNormGrp.bundled_hom

def bundled_hom : bundled_hom.parent_projection
  @profinitely_filtered_pseudo_normed_group.to_comphaus_filtered_pseudo_normed_group := ⟨⟩

local attribute [instance] bundled_hom

attribute [derive [large_category, concrete_category]] ProFiltPseuNormGrp

instance : has_coe_to_sort ProFiltPseuNormGrp Type* := bundled.has_coe_to_sort

instance : has_forget₂ ProFiltPseuNormGrp CompHausFiltPseuNormGrp := bundled_hom.forget₂ _ _

@[simps]
def to_CompHausFilt : ProFiltPseuNormGrp ⥤ CompHausFiltPseuNormGrp := forget₂ _ _

/-- Construct a bundled `ProFiltPseuNormGrp` from the underlying type and typeclass. -/
def of (M : Type u) [profinitely_filtered_pseudo_normed_group M] : ProFiltPseuNormGrp :=
bundled.of M

instance : has_zero ProFiltPseuNormGrp := ⟨of punit⟩

instance : inhabited ProFiltPseuNormGrp := ⟨0⟩

instance (M : ProFiltPseuNormGrp) : profinitely_filtered_pseudo_normed_group M := M.str

@[simp] lemma coe_of (V : Type u) [profinitely_filtered_pseudo_normed_group V] : (ProFiltPseuNormGrp.of V : Type u) = V := rfl

@[simp] lemma coe_id (V : ProFiltPseuNormGrp) : ⇑(𝟙 V) = id := rfl

@[simp] lemma coe_comp {A B C : ProFiltPseuNormGrp} (f : A ⟶ B) (g : B ⟶ C) :
  ⇑(f ≫ g) = g ∘ f := rfl

@[simp] lemma coe_comp_apply {A B C : ProFiltPseuNormGrp} (f : A ⟶ B) (g : B ⟶ C) (x : A) :
  (f ≫ g) x = g (f x) := rfl

open pseudo_normed_group

section

variables (M : Type*) [profinitely_filtered_pseudo_normed_group M] (c : ℝ≥0)

instance : t2_space (Top.of (filtration M c)) := by { dsimp, apply_instance }
instance : totally_disconnected_space (Top.of (filtration M c)) := by { dsimp, apply_instance }
instance : compact_space (Top.of (filtration M c)) := by { dsimp, apply_instance }

end

end ProFiltPseuNormGrp


-- Projection to the witness should be rejected.
def witness : Nat := (⟨1, Nat.le_refl _⟩ : ∃ x, x ≥ 1).1

-- Projection to the property as well (it could contain the witness projection).
theorem witness_eq (h : ∃ x : Nat, True) : h.2 = h.2 := rfl


import Tagless.Tests
import Tagless.Strong

structure Dsl where
  Repr : Type v → Type v
  Obsv : Type v → Type v

  observe
    {α : Type v}
  : Repr α → Obsv α

  val
    {α : Type v}
  : α → Repr α

  app
    {α β : Type v}
  : Repr (α → β) → Repr α → Repr β

def Dsl.example
  (dsl : Dsl)
: dsl.Repr Nat :=
  let v1 := dsl.val 7
  let v2 := dsl.val 3
  let f := dsl.val fun l r => l + r
  let tmp := dsl.app f v1
  dsl.app tmp v2

def Dsl.eval : Dsl where
  Repr := id
  Obsv := id

  observe := id

  val := id
  app f a := f a

#eval Dsl.example Dsl.eval


def foo (x : Nat) (_ : x = 0) : Nat := x
example : foo 0 (by simp [typo]; done) = 0 := sorry