import data.cpi.transition.basic data.multiset2 data.option2

-- TODO: Move this somewhere sensible
instance quot.lift.decidable_pred {α : Type*} [setoid α] (p : α → Prop) [dec : decidable_pred p] (h : ∀ a b, a ≈ b → p a = p b)
  : decidable_pred (quot.lift p h)
| x := quot.hrec_on x dec (λ x y r, subsingleton.helim (congr_arg decidable (h x y r)) (dec x) (dec y))

namespace cpi
namespace transition

variables {ℍ : Type} {ω : context}

/-- The set of all transitions from a nil species. -/
def enumerate_nil {Γ} {ℓ : lookup ℍ ω Γ}
  : fintype (transition.transition_from ℓ species.nil)
  := ⟨ finset.empty, (λ ⟨ k, α, E, t ⟩, by cases t) ⟩

/-- ξ_choice acts as an embedding. This is effectively ξ_choice.inj but lifted
    to transitions. -/
def ξ_choice.embed
    {Γ f} (ℓ : lookup ℍ ω Γ)
    (π : prefix_expr ℍ Γ f) (A : species ℍ ω (f.apply Γ)) (As : species.choices ℍ ω Γ)
  : transition_from ℓ (Σ# As) ↪ transition_from ℓ (Σ# (whole.cons π A As))
  := { to_fun := λ t, transition_from.mk (ξ_choice t.2.2.2),
       inj := λ ⟨ k, α, E, t ⟩ ⟨ k', α', E', t' ⟩ eq, by { cases eq, from rfl} }

private def enumerate_choice_communicate_ts {Γ} (ℓ : lookup ℍ ω Γ) :
  ∀ (a :  name Γ) (b : list (name Γ)) (y : ℕ)
    (A : species ℍ ω (context.extend y Γ))
    {As : species.choices ℍ ω Γ}
  , fintype (transition_from ℓ (Σ# As))
  → finset (transition_from ℓ (Σ# (whole.cons (a#(b;y)) A As)))
| a b y A As child :=
  finset.insert_nmem'
    (transition_from.mk (choice₁ a b rfl y A As))
    (finset.map (ξ_choice.embed ℓ _ A As) child.elems)
    (λ mem, begin
      rcases finset.mem_map.mp mem with ⟨ ⟨ k, α, E, t ⟩, mem, eql ⟩,

      unfold_coes at eql,
      simp only [ξ_choice.embed, transition_from.mk] at eql,
      unfold_projs at eql,
      cases eql,
    end)

private def enumerate_choice_communicate {Γ} (ℓ : lookup ℍ ω Γ) :
  ∀ (a :  name Γ) (b : list (name Γ)) (y : ℕ)
    (A : species ℍ ω (context.extend y Γ))
    {As : species.choices ℍ ω Γ}
  , fintype (transition_from ℓ (Σ# As))
  → fintype (transition_from ℓ (Σ# (whole.cons (a#(b;y)) A As)))
| a b y A As child :=
  { elems := enumerate_choice_communicate_ts ℓ a b y A child,
    complete := λ x, begin
      rcases x with ⟨ k, α, E, t ⟩,
      cases t,
      case ξ_choice {
        have : transition_from.mk t_a ∈ child.elems := @fintype.complete _ child _,
        have this := finset.mem_map_of_mem (ξ_choice.embed ℓ (a#(b;y)) A As) this,
        from finset.mem_insert_nmem_of_mem this _,
      },
      case choice₁ {
        subst t_b_len,
        from finset.mem_insert_nmem_self _
      },
    end }

private def enumerate_choice_spontaneous_ts {Γ} (ℓ : lookup ℍ ω Γ) :
  ∀ (k : ℍ) (A : species ℍ ω Γ) {As : species.choices ℍ ω Γ}
  , fintype (transition_from ℓ (Σ# As))
  → finset (transition_from ℓ (Σ# (whole.cons (τ@k) A As)))
| k A As child :=
  finset.insert_nmem'
    (transition_from.mk (choice₂ k A As))
    (finset.map (ξ_choice.embed ℓ _ A As) child.elems)
    (λ mem, begin
      rcases finset.mem_map.mp mem with ⟨ ⟨ k, α, E, t ⟩, mem, eql ⟩,

      unfold_coes at eql,
      simp only [ξ_choice.embed, transition_from.mk] at eql,
      unfold_projs at eql,
      cases eql,
    end)

private def enumerate_choice_spontaneous {Γ} (ℓ : lookup ℍ ω Γ) :
  ∀ (k : ℍ) (A : species ℍ ω Γ) {As : species.choices ℍ ω Γ}
  , fintype (transition_from ℓ (Σ# As))
  → fintype (transition_from ℓ (Σ# (whole.cons (τ@k) A As)))
| k A As child :=
  { elems := enumerate_choice_spontaneous_ts ℓ k A child,
    complete := λ x, begin
      rcases x with ⟨ k', α, E, t ⟩,
      cases t,
      case ξ_choice {
        have : transition_from.mk t_a ∈ child.elems := @fintype.complete _ child _,
        have this := finset.mem_map_of_mem (ξ_choice.embed ℓ (τ@k) A As) this,
        from finset.mem_insert_nmem_of_mem this _,
      },
      case choice₂ { from finset.mem_insert_nmem_self _ },
    end }

/-- The set of all transitions from a guarded choice species. -/
def enumerate_choices {Γ} (ℓ : lookup ℍ ω Γ) :
  ∀ (As : species.choices ℍ ω Γ), fintype (transition_from ℓ (Σ# As))
| species.whole.empty :=
  { elems := finset.empty,
    complete := λ ⟨ k, α, E, t ⟩, by cases t }
| (species.whole.cons (a#(b; y)) A As) := enumerate_choice_communicate ℓ a b y A (enumerate_choices As)
| (species.whole.cons (τ@k) A As) := enumerate_choice_spontaneous ℓ k A (enumerate_choices As)

private def defn.from {Γ n} (ℓ : lookup ℍ ω Γ) (D : reference n ω) (as : vector (name Γ) n)
  : transition_from ℓ (Σ# (species.rename (name.mk_apply as) (ℓ _ D)))
  → transition_from ℓ (apply D as)
| ⟨ k, α, E, t ⟩ := ⟨ k, α, E, defn _ _ _ _ rfl t ⟩

private def defn.embed {Γ n} (ℓ : lookup ℍ ω Γ) (D : reference n ω) (as : vector (name Γ) n)
  : transition_from ℓ (Σ# (species.rename (name.mk_apply as) (ℓ _ D)))
  ↪ transition_from ℓ (apply D as)
  := ⟨ defn.from ℓ D as, λ t t' eql, begin
    rcases t with ⟨ k, α, E, t ⟩, rcases t' with ⟨ k', α', E', t' ⟩,
    simp only [defn.from] at eql,

    rcases sigma.mk.inj eql with ⟨ ⟨ _ ⟩, eql₁ ⟩, clear eql,
    rcases sigma.mk.inj (eq_of_heq eql₁) with ⟨ ⟨ _ ⟩, eql₂ ⟩, clear eql₁,
    rcases sigma.mk.inj (eq_of_heq eql₂) with ⟨ ⟨ _ ⟩, eql₃ ⟩, clear eql₂,
    have eql := eq_of_heq (defn.inj (eq_of_heq eql₃)).2, clear eql₃, subst eql,
  end ⟩

private def enumerate_apply_ts {Γ n} (ℓ : lookup ℍ ω Γ) (D : reference n ω) (as : vector (name Γ) n)
  : finset (transition_from ℓ (apply D as))
  := finset.map (defn.embed ℓ D as)
      (enumerate_choices ℓ (species.rename (name.mk_apply as) (ℓ _ D))).elems

private lemma enumerate_apply_complete {Γ n} (ℓ : lookup ℍ ω Γ) (D : reference n ω) (as : vector (name Γ) n)
  : ∀ x, x ∈ enumerate_apply_ts ℓ D as
| ⟨ k, α, E, defn ℓ' D as B eql t ⟩ := begin
  subst eql,
  have h :=
    @fintype.complete _
      (enumerate_choices ℓ (species.rename (name.mk_apply as) (ℓ _ D)))
      (transition_from.mk t),
  from finset.mem_map_of_mem (defn.embed ℓ D as) h,
end

/-- The set of all transitions from a species invocation. -/
def enumerate_apply {Γ n} (ℓ : lookup ℍ ω Γ) (D : reference n ω) (as : vector (name Γ) n)
  : fintype (transition_from ℓ (apply D as)) :=
  ⟨ enumerate_apply_ts ℓ D as, enumerate_apply_complete ℓ D as ⟩

/-- Wrap a transition in parL. -/
def parL {Γ : context} {ℓ : lookup ℍ ω Γ} (A B : species ℍ ω Γ)
  : transition.transition_from ℓ A → transition.transition_from ℓ (A |ₛ B)
| ⟨ _, α, production.species E, t ⟩ := ⟨ _, α, _, transition.parL_species B t ⟩
| ⟨ _, α, production.concretion E, t ⟩ := ⟨ _, α, _, transition.parL_concretion B t ⟩

/-- Wrap a transition in parL, as a function embedding. -/
def parL.embed {Γ} {ℓ : lookup ℍ ω Γ} (A B : species ℍ ω Γ)
  : transition.transition_from ℓ A ↪ transition.transition_from ℓ (A |ₛ B)
  := ⟨ parL A B, λ t t' eq, begin
        rcases t with ⟨ k, α, E, t ⟩, rcases t' with ⟨ k', α', E', t' ⟩,
          cases E; cases E'; cases eq; from rfl,
        end ⟩

/-- Wrap a transition in parR. -/
def parR {Γ} {ℓ : lookup ℍ ω Γ} (A B : species ℍ ω Γ)
  : transition.transition_from ℓ B → transition.transition_from ℓ (A |ₛ B)
| ⟨ _, α, production.species E, t ⟩ := ⟨ _, α, _, transition.parR_species A t ⟩
| ⟨ _, α, production.concretion E, t ⟩ := ⟨ _, α, _, transition.parR_concretion A t ⟩

/-- Wrap a transition in parL, as a function embedding. -/
def parR.embed {Γ} {ℓ : lookup ℍ ω Γ} (A B : species ℍ ω Γ)
  : transition.transition_from ℓ B ↪ transition.transition_from ℓ (A |ₛ B)
  := ⟨ parR A B, λ t t' eq, begin
        rcases t with ⟨ k, α, E, t ⟩, rcases t' with ⟨ k', α', E', t' ⟩,
          cases E; cases E'; cases eq; from rfl,
        end ⟩

/-- Determine if two transitions result have products with compatible
    concretions. -/
private def com₁.is_compatible {Γ} (ℓ : lookup ℍ ω Γ) (A B : species ℍ ω Γ)
  : transition.transition_from ℓ A × transition.transition_from ℓ B
  → Prop
| ⟨ ⟨ _, l, @production.concretion _ _ _ a x F, t ⟩,
    ⟨ _, l', @production.concretion _ _ _ b y G, t' ⟩ ⟩ := a = y ∧ b = x
| ⟨ ⟨ _, l, production.concretion F, t ⟩, ⟨ _, l', production.species G, t' ⟩ ⟩ := false
| ⟨ ⟨ _, l, production.species F, t ⟩, ⟨ _, l', production.concretion G, t' ⟩ ⟩ := false
| ⟨ ⟨ _, l, production.species F, t ⟩, ⟨ _, l', production.species G, t' ⟩ ⟩ := false

instance com₁.is_compatible.decide {Γ} (ℓ : lookup ℍ ω Γ) (A B : species ℍ ω Γ)
  : decidable_pred (com₁.is_compatible ℓ A B)
| ⟨ ⟨ _, l, @production.concretion _ _ _ a x F, t ⟩,
    ⟨ _, l', @production.concretion _ _ _ b y G, t' ⟩ ⟩
    := by { unfold com₁.is_compatible, by apply_instance }
| ⟨ ⟨ _, l, production.concretion F, t ⟩, ⟨ _, l', production.species G, t' ⟩ ⟩ := decidable.false
| ⟨ ⟨ _, l, production.species F, t ⟩, ⟨ _, l', production.concretion G, t' ⟩ ⟩ := decidable.false
| ⟨ ⟨ _, l, production.species F, t ⟩, ⟨ _, l', production.species G, t' ⟩ ⟩ := decidable.false

/-- The subtype of all transition pairs which are compatible. -/
@[nolint has_inhabited_instance]
def com₁.compatible {Γ} (ℓ : lookup ℍ ω Γ) (A B : species ℍ ω Γ) : Type
  := { p : transition.transition_from ℓ A × transition.transition_from ℓ B
     // com₁.is_compatible ℓ A B p }

/-- Convert a compatible pair of transitions to a com₁ transition. -/
def com₁.of_compatible {Γ} (ℓ : lookup ℍ ω Γ) (A B : species ℍ ω Γ)
  : com₁.compatible ℓ A B → transition.transition_from ℓ (A |ₛ B)
| ⟨ ⟨ ⟨ _, l, @production.concretion _ _ _ a x F, t ⟩,
     ⟨ _, l', @production.concretion _ _ _ b y G, t' ⟩ ⟩, p ⟩ := begin
  cases l with _ a, cases l' with _ b, rcases p with ⟨ ⟨ _ ⟩, ⟨ _ ⟩ ⟩,
  refine ⟨ _, _, _, com₁ rfl rfl t t' ⟩,
end
| ⟨ ⟨ ⟨ _, l, production.concretion F, t ⟩, ⟨ _, l', production.species G, t' ⟩ ⟩, p ⟩ := false.elim p
| ⟨ ⟨ ⟨ _, l, production.species F, t ⟩, ⟨ _, l', production.concretion G, t' ⟩ ⟩, p ⟩ := false.elim p
| ⟨ ⟨ ⟨ _, l, production.species F, t ⟩, ⟨ _, l', production.species G, t' ⟩ ⟩, p ⟩ := false.elim p

/-- We need a separate lemma to show com₁.of_compatible - we need to
    generalise several variables, otherwise the case splits do not go through.
-/
private lemma com₁.of_compatible.inj_help {Γ} {ℓ : lookup ℍ ω Γ} (A B : species ℍ ω Γ) :
  ∀ {a x} {a₁ b₁} {F₁ : concretion ℍ ω Γ a x} {G₁ : concretion ℍ ω Γ x a}
    {b y} {a₂ b₂} {F₂ : concretion ℍ ω Γ b y} {G₂ : concretion ℍ ω Γ y b}
    {FG₁ FG₂ : species ℍ ω Γ} {α₁ α₂ : label ℍ Γ kind.species}
    (eFG₁ : FG₁ = concretion.pseudo_apply F₁ G₁)
    (eFG₂ : FG₂ = concretion.pseudo_apply F₂ G₂)
    (eα₁ : α₁ = τ⟨ a₁, b₁ ⟩) (eα₂ : α₂ = τ⟨ a₂, b₂ ⟩)
    (tf₁ : A [ℓ, #a₁]⟶ (production.concretion F₁)) (tg₁ : B [ℓ, #b₁]⟶ (production.concretion G₁))
    (tf₂ : A [ℓ, #a₂]⟶ (production.concretion F₂)) (tg₂ : B [ℓ, #b₂]⟶ (production.concretion G₂))
  , (τ⟨ a₁, b₁ ⟩ = (τ⟨ a₂, b₂ ⟩ : label ℍ Γ _))
  → sigma.mk (production.species FG₁) (com₁ eFG₁ eα₁ tf₁ tg₁)
  == sigma.mk (production.species FG₂) (com₁ eFG₂ eα₂ tf₂ tg₂)
  → a = b ∧ x = y ∧ a₁ = a₂ ∧ b₁ = b₂ ∧ F₁ == F₂ ∧ G₁ == G₂ ∧ tf₁ == tf₂ ∧ tg₁ == tg₂
| a x a₁ b₁ F₁ G₁ b y a₂ b₂ F₂ G₂ FG₁ FG₂ α₁ α₂ eFG₁ eFG₂ eα₁ eα₂
  tf₁ tg₁ tf₂ tg₂ eqα eqT := begin
  have : α₁ = α₂ := trans eα₁ (trans eqα eα₂.symm), subst this,
  rcases sigma.mk.inj (eq_of_heq eqT) with ⟨ eqFG, eqT ⟩,
  have : FG₁ = FG₂ := production.species.inj eqFG, subst this,

  rcases com₁.inj (eq_of_heq eqT) with ⟨ ⟨ _ ⟩, ⟨ _ ⟩, ⟨ _ ⟩, ⟨ _ ⟩, F, G, tf, tg ⟩,
  from ⟨ rfl, rfl, rfl, rfl, F, G, tf, tg ⟩,
end

private lemma com₁.of_compatible.inj {Γ} {ℓ : lookup ℍ ω Γ} (A B : species ℍ ω Γ)
  : function.injective (com₁.of_compatible ℓ A B)
| ⟨ ⟨ ⟨ k₁, α₁, E₁, t₁ ⟩, ⟨ k₁', α₁', E₁', t₁' ⟩ ⟩, is₁ ⟩
  ⟨ ⟨ ⟨ k₂, α₂, E₂, t₂ ⟩, ⟨ k₂', α₂', E₂', t₂' ⟩ ⟩, is₂ ⟩ eql := begin
  cases E₁; cases E₁'; try { unfold com₁.is_compatible at is₁, contradiction },
  rcases is₁ with ⟨ l, r ⟩, subst l, subst r, cases α₁, cases α₁',

  cases E₂; cases E₂'; try { unfold com₁.is_compatible at is₂, contradiction },
  rcases is₂ with ⟨ l, r ⟩, subst l, subst r, cases α₂, cases α₂',

  simp only [com₁.of_compatible] at eql,

  rcases sigma.mk.inj (eq_of_heq (sigma.mk.inj eql).2) with ⟨ eqα, eqT ⟩,
  rcases com₁.of_compatible.inj_help A B rfl rfl rfl rfl t₁ t₁' t₂ t₂' eqα eqT
    with ⟨ ⟨ _ ⟩, ⟨ _ ⟩, ⟨ _ ⟩, ⟨ _ ⟩, ⟨ _ ⟩, ⟨ _ ⟩, ⟨ _ ⟩, ⟨ _ ⟩ ⟩,
  from rfl,
end

/-- Convert a compatible pair of transitions to a com₁ transition. -/
def com₁.embed {Γ} (ℓ : lookup ℍ ω Γ) (A B : species ℍ ω Γ)
  : com₁.compatible ℓ A B ↪ transition.transition_from ℓ (A |ₛ B)
  := ⟨ com₁.of_compatible ℓ A B, com₁.of_compatible.inj A B ⟩

private lemma com₁.impossible_l {Γ}
    (ℓ : lookup ℍ ω Γ) (A B : species ℍ ω Γ) {b y}
    {F : concretion ℍ ω Γ b y} {G : concretion ℍ ω Γ y b}
  : ∀ {a₁ a₂} {C FG : species ℍ ω Γ}
      (t : A [ℓ, τ⟨ a₁, a₂ ⟩]⟶ (production.species C))
      (t₁ : A [ℓ, #a₁]⟶ (production.concretion F))
      (t₂ : B [ℓ, #a₂]⟶ (production.concretion G))
      (h : FG = concretion.pseudo_apply F G)
    , (C |ₛ B) = FG
    → ¬ (parL_species B t == com₁ h rfl t₁ t₂)
| a₁ a₂ C FG t t₁ t₂ h cfg eql := by { subst cfg, cases (eq_of_heq eql) }

private lemma com₁.impossible_r {Γ}
    (ℓ : lookup ℍ ω Γ) (A B : species ℍ ω Γ) {b y}
    {F : concretion ℍ ω Γ b y} {G : concretion ℍ ω Γ y b}
  : ∀ {a₁ a₂} {C FG : species ℍ ω Γ}
      (t : B [ℓ, τ⟨ a₁, a₂ ⟩]⟶ (production.species C))
      (t₁ : A [ℓ, #a₁]⟶ (production.concretion F))
      (t₂ : B [ℓ, #a₂]⟶ (production.concretion G))
      (h : FG = concretion.pseudo_apply F G)
    , (A |ₛ C) = FG
    → ¬ (parR_species A t == com₁ h rfl t₁ t₂)
| a₁ a₂ C FG t t₁ t₂ h cfg eql := by { subst cfg, cases (eq_of_heq eql) }

private def enumerate_parallel_ts {Γ} {ℓ : lookup ℍ ω Γ} (A B : species ℍ ω Γ)
  : fintype (transition.transition_from ℓ A)
  → fintype (transition.transition_from ℓ B)
  → finset (transition.transition_from ℓ (A |ₛ B))
| As Bs :=
  finset.union_disjoint
    (finset.map
      (com₁.embed ℓ A B)
      ((finset.product As.elems Bs.elems).subtype (com₁.is_compatible ℓ A B)))
    (finset.union_disjoint
      (As.elems.map (parL.embed A B))
      (Bs.elems.map (parR.embed A B))
      (λ x memL memR, begin
        rcases finset.mem_map.mp memL with ⟨ ⟨ k, α, E, t ⟩, mem, eql ⟩, clear mem,
        unfold_coes at eql, simp only [parL.embed] at eql, subst eql,

        rcases finset.mem_map.mp memR with ⟨ ⟨ k', α', E', t' ⟩, mem, eql ⟩, clear mem,
        unfold_coes at eql, simp only [parR.embed] at eql,

        cases E; cases E'; simp only [parL, parR] at eql; cases eql,
      end))
    (λ x memL memR, begin
      rcases finset.mem_map.mp memL with ⟨ ⟨ ⟨ ⟨ k₁, α₁, E₁, t₁ ⟩, ⟨ k₂, α₂, E₂, t₂ ⟩ ⟩, d ⟩, mem, eql ⟩, clear memL mem,
      unfold_coes at eql, simp only [com₁.embed] at eql,
      cases E₁; cases E₂; try { simpa only [com₁.is_compatible] using d },
      rcases d with ⟨ ⟨ _ ⟩, ⟨ _ ⟩ ⟩, cases α₁, cases α₂,
      simp only [com₁.of_compatible] at eql, subst eql,

      cases finset.mem_union_disjoint.mp memR,
      case or.inl {
        rcases finset.mem_map.mp h with ⟨ ⟨ k, α, E, t ⟩, mem, eql ⟩, clear mem memR,
        unfold_coes at eql, simp only [parL.embed] at eql,
        cases E,
        case production.species {
          rcases sigma.mk.inj eql with ⟨ ⟨ _ ⟩, eql₁ ⟩, clear eql,
          rcases sigma.mk.inj (eq_of_heq eql₁) with ⟨ ⟨ _ ⟩, eql₂ ⟩, clear eql₁,
          rcases sigma.mk.inj (eq_of_heq eql₂) with ⟨ eqlE, eqlT ⟩,

          from com₁.impossible_l ℓ A B t t₁ t₂ rfl (production.species.inj eqlE) eqlT,
        },
        case production.concretion { cases (sigma.mk.inj eql).1 },
      },
      case or.inr {
        rcases finset.mem_map.mp h with ⟨ ⟨ k, α, E, t ⟩, mem, eql ⟩, clear mem memR,
        unfold_coes at eql, simp only [parR.embed] at eql,
        cases E,
        case production.species {
          rcases sigma.mk.inj eql with ⟨ ⟨ _ ⟩, eql₁ ⟩, clear eql,
          rcases sigma.mk.inj (eq_of_heq eql₁) with ⟨ ⟨ _ ⟩, eql₂ ⟩, clear eql₁,
          rcases sigma.mk.inj (eq_of_heq eql₂) with ⟨ eqlE, eqlT ⟩,

          from com₁.impossible_r ℓ A B t t₁ t₂ rfl (production.species.inj eqlE) eqlT,
        },
        case production.concretion { cases (sigma.mk.inj eql).1 },
      },
    end)

private lemma enumate_parallel_compute_l_species
    {Γ ℓ} {A B : species ℍ ω Γ} {l : label ℍ Γ kind.species} {E}
    (As : fintype (transition_from ℓ A)) (Bs : fintype (transition_from ℓ B))
    (t : transition A ℓ l (production.species E))
  : transition_from.mk (parL_species B t) ∈ enumerate_parallel_ts A B As Bs :=
  let h := @fintype.complete _ As (transition_from.mk t) in
  let g := finset.mem_map_of_mem (parL.embed A B) h in
  finset.mem_union_disjoint.mpr (or.inr (finset.mem_union_disjoint.mpr (or.inl g)))

private lemma enumate_parallel_compute_l_concretion
    {Γ ℓ} {A B} {l : label ℍ Γ kind.concretion} {b y} {E : concretion ℍ ω Γ b y}
    (As : fintype (transition_from ℓ A)) (Bs : fintype (transition_from ℓ B))
    (t : transition A ℓ l (production.concretion E))
  : transition_from.mk (parL_concretion B t) ∈ enumerate_parallel_ts A B As Bs :=
  let h := @fintype.complete _ As (transition_from.mk t) in
  let g := finset.mem_map_of_mem (parL.embed A B) h in
  finset.mem_union_disjoint.mpr (or.inr (finset.mem_union_disjoint.mpr (or.inl g)))

private lemma enumate_parallel_compute_r_species
    {Γ ℓ} {A B : species ℍ ω Γ} {l : label ℍ Γ kind.species} {E}
    (As : fintype (transition_from ℓ A)) (Bs : fintype (transition_from ℓ B))
    (t : transition B ℓ l (production.species E))
  : transition_from.mk (parR_species A t) ∈ enumerate_parallel_ts A B As Bs :=
  let h := @fintype.complete _ Bs (transition_from.mk t) in
  let g := finset.mem_map_of_mem (parR.embed A B) h in
  finset.mem_union_disjoint.mpr (or.inr (finset.mem_union_disjoint.mpr (or.inr g)))

private lemma enumerate_parallel_complete {Γ} {ℓ : lookup ℍ ω Γ} (A B : species ℍ ω Γ)
    (As : fintype (transition.transition_from ℓ A)) (Bs : fintype (transition.transition_from ℓ B))
  : ∀ x, x ∈ enumerate_parallel_ts A B As Bs
| ⟨ k, α, E, parL_species _ t ⟩ := enumate_parallel_compute_l_species As Bs t
| ⟨ k, α, E, parL_concretion _ t ⟩ := enumate_parallel_compute_l_concretion As Bs t
| ⟨ k, α, E, parR_species _ t ⟩ := enumate_parallel_compute_r_species As Bs t
| ⟨ k, α, E, parR_concretion _ t ⟩ :=
  let h := @fintype.complete _ Bs (transition_from.mk t) in
  let g := finset.mem_map_of_mem (parR.embed A B) h in
  finset.mem_union_disjoint.mpr (or.inr (finset.mem_union_disjoint.mpr (or.inr g)))
| ⟨ k, α, E, com₁ eqFG eqα tf tg ⟩ := begin
  subst eqFG, subst eqα,
  let t : com₁.compatible ℓ A B
    := ⟨ ( transition_from.mk tf, transition_from.mk tg ), ⟨ rfl, rfl ⟩ ⟩,
  have h
    := finset.mem_subtype.mpr
      (finset.mem_product.mpr ⟨ @fintype.complete _ As t.val.1, @fintype.complete _ Bs t.val.2 ⟩),
  from finset.mem_union_disjoint.mpr (or.inl (finset.mem_map_of_mem (com₁.embed ℓ A B) h)),
end

/-- The set of all transitions from a parallel composition of species -/
def enumerate_parallel {Γ} {ℓ : lookup ℍ ω Γ} {A B : species ℍ ω Γ}
  : fintype (transition.transition_from ℓ A)
  → fintype (transition.transition_from ℓ B)
  → fintype (transition.transition_from ℓ (A |ₛ B))
| As Bs := ⟨ enumerate_parallel_ts A B As Bs, enumerate_parallel_complete A B As Bs ⟩

private def is_restriction_name {Γ} (M : affinity ℍ)
  : name (context.extend M.arity Γ) → name (context.extend M.arity Γ)
  → Prop
| (name.zero a) (name.zero b) := option.is_some' (M.f a b)
| (name.extend _) (name.extend _) := true
| (name.extend _) (name.zero _) := false
| (name.zero _) (name.extend _) := false

private def is_restriction_name.comm {Γ} (M : affinity ℍ)
  : ∀ (a b : name (context.extend M.arity Γ))
  , is_restriction_name M a b = is_restriction_name M b a
| a b := by { cases a; cases b; from rfl <|> simp only [is_restriction_name, M.symm] }

private def is_restriction_like {Γ} (ℓ : lookup ℍ ω Γ) (M : affinity ℍ) (A : species ℍ ω (context.extend M.arity Γ))
  : transition.transition_from (lookup.rename name.extend ℓ) A
  → Prop
| ⟨ _, τ⟨ p ⟩, E, t ⟩ := upair.lift_on p (is_restriction_name M) (is_restriction_name.comm M)
| ⟨ _, τ@' k, E, t ⟩ := true
| ⟨ _, # (name.zero n), E, t ⟩ := false
| ⟨ _, # (name.extend n), E, t ⟩ := true

private def is_restriction {Γ} (ℓ : lookup ℍ ω Γ) (M : affinity ℍ) (A : species ℍ ω (context.extend M.arity Γ))
  := { t : transition_from (lookup.rename name.extend ℓ) A // is_restriction_like ℓ M A t }

private def is_restriction.name_lift {Γ} (ℓ : lookup ℍ ω Γ) (M : affinity ℍ)
  (A : species ℍ ω (context.extend M.arity Γ))
  (B : species ℍ ω (context.extend M.arity Γ)) :
  ∀ (a b : name (context.extend M.arity Γ))
  , is_restriction_name M a b
  → A [lookup.rename name.extend ℓ, τ⟨ a, b ⟩]⟶ (production.species B)
  → transition.transition_from ℓ (ν(M) A)
| (name.zero a) (name.zero b) is_some t :=
  let this : M.get (upair.mk a b) = some (option.get' is_some) := option.eq_some_of_is_some' is_some in
  ⟨ _, _, _, com₂ M (option.get' is_some) this rfl t ⟩
| (name.extend a) (name.extend b) fls t := begin
  have : τ⟨ name.extend a, name.extend b ⟩ = label.rename (@name.extend Γ M.arity) (τ⟨ a, b ⟩),
  { simpa only [label.rename] },
  from ⟨ _, _, _, ν₁_species M this t ⟩,
end
| (name.extend _) (name.zero _) fls t := false.elim fls
| (name.zero a) (name.extend b) fls t := false.elim fls

private lemma is_restriction_name_lift.comm_zero {Γ} {ℓ : lookup ℍ ω Γ} (M : affinity ℍ) (A B : species ℍ ω (context.extend M.arity Γ))
    {x y : fin M.arity}
    {tL : A [lookup.rename name.extend ℓ, τ⟨ (upair.mk (name.zero x) (name.zero y)) ⟩]⟶ (production.species B)}
    {tR : A [lookup.rename name.extend ℓ, τ⟨ (upair.mk (name.zero y) (name.zero x)) ⟩]⟶ (production.species B)}
    (eT : tL == tR)
    (k₁ k₂ : ℍ)
    (e₁ : M.get (upair.mk x y) = some k₁)
    (e₂ : M.get (upair.mk y x) = some k₂)
  : transition.transition_from.mk (com₂ M k₁ e₁ rfl tL)  = transition.transition_from.mk (com₂ M k₂ e₂ rfl tR) := begin
  have : k₁ = k₂,
  {
    rw upair.mk.comm at e₁,
    from option.some.inj (trans e₁.symm e₂),
  }, subst this,

  refine sigma.mk.inj_iff.mpr ⟨ rfl, heq_of_eq _ ⟩, simp only [heq_iff_eq],
  from ⟨ rfl, ⟨ rfl, rfl ⟩, quot.sound (or.inr ⟨ rfl, rfl ⟩), quot.sound (or.inr ⟨ rfl, rfl ⟩), eT ⟩,
end

private lemma is_restriction_name_lift.comm_extend {Γ} {ℓ : lookup ℍ ω Γ} (M : affinity ℍ) (A B : species ℍ ω (context.extend M.arity Γ))
    {x y : name Γ}
    {tL : A [lookup.rename name.extend ℓ, τ⟨ (upair.mk (name.extend x) (name.extend y)) ⟩]⟶ (production.species B)}
    {tR : A [lookup.rename name.extend ℓ, τ⟨ (upair.mk (name.extend y) (name.extend x)) ⟩]⟶ (production.species B)}
    (eT : tL == tR)
    (l₁ l₂ : label ℍ Γ kind.species)
    (e₁ : τ⟨ (upair.mk (name.extend x) (name.extend y)) ⟩ = label.rename name.extend l₁)
    (e₂ : τ⟨ (upair.mk (name.extend y) (name.extend x)) ⟩ = label.rename name.extend l₂)
  : transition.transition_from.mk (ν₁_species M e₁ tL) = transition.transition_from.mk (ν₁_species M e₂ tR) := begin
  have : l₁ = l₂,
  {
    rw [upair.mk.comm] at e₁,
    from label.rename.inj (@name.extend.inj _ _) (trans e₁.symm e₂),
  }, subst this,

  refine sigma.mk.inj_iff.mpr ⟨ rfl, heq_of_eq _ ⟩, simp only [heq_iff_eq],
  from ⟨ rfl, ⟨ rfl, rfl ⟩, quot.sound (or.inr ⟨ rfl, rfl ⟩), eT ⟩,
end

private lemma is_restriction.name_lift.comm {Γ} (ℓ : lookup ℍ ω Γ) (M : affinity ℍ) (A B : species ℍ ω (context.extend M.arity Γ)) :
  ∀ (a b : name (context.extend M.arity Γ))
  ,  is_restriction.name_lift ℓ M A B a b
  == is_restriction.name_lift ℓ M A B b a
| (name.zero x) (name.zero y) := function.hfunext
  (by { unfold is_restriction_name, rw M.symm })
  (λ irlL irlR eIRL, function.hfunext
    (by rw upair.mk.comm)
    (λ tL tR eT, heq_of_eq (is_restriction_name_lift.comm_zero M A B eT _ _ _ _)))
| (name.extend x) (name.extend y) := function.hfunext rfl
  (λ irlL irlR eIRL, function.hfunext
    (by rw upair.mk.comm)
    (λ tL tR eT, heq_of_eq (is_restriction_name_lift.comm_extend M A B eT _ _ _ _)))
| (name.zero x) (name.extend y) := function.hfunext rfl
    (λ irlL irlR eIRL, function.hfunext (by rw upair.mk.comm) (λ x b z, heq.rfl))
| (name.extend x) (name.zero y) := function.hfunext rfl
    (λ irlL irlR eIRL, function.hfunext (by rw upair.mk.comm) (λ x b z, heq.rfl))

lemma ν₁_species.inj' {Γ} {ℓ : lookup ℍ ω Γ} (M : affinity ℍ) {A} :
  ∀ {E₁ E₂}
    {l₁ : label ℍ Γ kind.species} {l'₁ : label ℍ (context.extend M.arity Γ) kind.species}
    {l₂ : label ℍ Γ kind.species} {l'₂ : label ℍ (context.extend M.arity Γ) kind.species}
    {e₁ : l'₁ = label.rename name.extend l₁}
    {e₂ : l'₂ = label.rename name.extend l₂}
    {t₁ : A [lookup.rename name.extend ℓ, l'₁]⟶ (production.species E₁)}
    {t₂ : A [lookup.rename name.extend ℓ, l'₂]⟶ (production.species E₂)}
  , transition_from.mk (ν₁_species M e₁ t₁) = transition_from.mk (ν₁_species M e₂ t₂)
  → transition_from.mk t₁ = transition_from.mk t₂
| E₁ E₂ l₁ l'₁ l₂ l'₂ e₁ e₂ t₁ t₂ eql := begin
  rcases sigma.mk.inj (eq_of_heq (sigma.mk.inj eql).2) with ⟨ this, eqR ⟩, subst ‹l₁ = l₂›,
  have : l'₁ = l'₂ := trans e₁ e₂.symm, subst ‹l'₁ = l'₂›,

  rcases sigma.mk.inj (eq_of_heq eqR) with ⟨ ⟨ _ ⟩, eqT ⟩,
  rcases ν₁_species.inj (eq_of_heq eqT) with ⟨ _, ⟨ _ ⟩ ⟩,
  from rfl,
end

lemma ν₁_concretion.inj' {Γ} {ℓ : lookup ℍ ω Γ} (M : affinity ℍ) {A} :
  ∀ {a x b y} {E₁ : concretion ℍ ω _ a x} {E₂ : concretion ℍ ω _ b y}
    {l₁ : label ℍ Γ kind.concretion} {l'₁ : label ℍ (context.extend M.arity Γ) kind.concretion}
    {l₂ : label ℍ Γ kind.concretion} {l'₂ : label ℍ (context.extend M.arity Γ) kind.concretion}
    {e₁ : l'₁ = label.rename name.extend l₁}
    {e₂ : l'₂ = label.rename name.extend l₂}
    {t₁ : A [lookup.rename name.extend ℓ, l'₁]⟶ (production.concretion E₁)}
    {t₂ : A [lookup.rename name.extend ℓ, l'₂]⟶ (production.concretion E₂)}
  , transition_from.mk (ν₁_concretion M e₁ t₁) = transition_from.mk (ν₁_concretion M e₂ t₂)
  → transition_from.mk t₁ = transition_from.mk t₂
| a x b y E₁ E₂ l₁ l'₁ l₂ l'₂ e₁ e₂ t₁ t₂ eql := begin
  rcases sigma.mk.inj (eq_of_heq (sigma.mk.inj eql).2) with ⟨ this, eqR ⟩, subst ‹l₁ = l₂›,
  have : l'₁ = l'₂ := trans e₁ e₂.symm, subst ‹l'₁ = l'₂›,

  rcases sigma.mk.inj (eq_of_heq eqR) with ⟨ ⟨ _ ⟩, eqT ⟩,
  rcases ν₁_concretion.inj (eq_of_heq eqT) with ⟨ _, ⟨ _ ⟩ ⟩,
  from rfl,
end

private lemma is_restriction.name_lift.inj_zero {Γ} (ℓ : lookup ℍ ω Γ) (M : affinity ℍ)
    (A : species ℍ ω (context.extend M.arity Γ)) :
  ∀ {B₁ B₂ : species ℍ ω (context.extend M.arity Γ)}
    {p q : upair (fin M.arity)}
    {t₁ : A [lookup.rename name.extend ℓ, τ⟨ (upair.map name.zero p) ⟩]⟶ (production.species B₁)}
    {t₂ : A [lookup.rename name.extend ℓ, τ⟨ (upair.map name.zero q) ⟩]⟶ (production.species B₂)}
    {k₁ k₂ : ℍ} {e₁ : M.get p = some k₁} {e₂ : M.get q = some k₂}
  , transition_from.mk (com₂ M k₁ e₁ rfl t₁) = transition_from.mk (com₂ M k₂ e₂ rfl t₂)
  → transition_from.mk t₁ = transition_from.mk t₂
| B₁ B₂ p q t₁ t₂ k₁ k₂ e₁ e₂ eql := begin
  rcases sigma.mk.inj (eq_of_heq (sigma.mk.inj eql).2) with ⟨ ⟨ _ ⟩, eqR ⟩,
  rcases sigma.mk.inj (eq_of_heq eqR) with ⟨ ⟨ _ ⟩, eqT ⟩,
  rcases com₂.inj (eq_of_heq eqT) with ⟨ ⟨ _ ⟩, ⟨ _ ⟩, ⟨ _ ⟩ ⟩,
  from rfl,
end

private lemma is_restriction.name_lift.inj {Γ} (ℓ : lookup ℍ ω Γ) (M : affinity ℍ)
    (A : species ℍ ω (context.extend M.arity Γ)) {B₁ B₂ : species ℍ ω (context.extend M.arity Γ)} :
  ∀ {a₁ b₁ a₂ b₂ : name (context.extend M.arity Γ)}
    (t₁ : A [lookup.rename name.extend ℓ, τ⟨ a₁, b₁ ⟩]⟶ (production.species B₁))
    (t₂ : A [lookup.rename name.extend ℓ, τ⟨ a₂, b₂ ⟩]⟶ (production.species B₂))
    (irl₁ : is_restriction_name M a₁ b₁)
    (irl₂ : is_restriction_name M a₂ b₂)
  , is_restriction.name_lift ℓ M A B₁ a₁ b₁ irl₁ t₁ = is_restriction.name_lift ℓ M A B₂ a₂ b₂ irl₂ t₂
  → transition_from.mk t₁ = transition_from.mk t₂
| a₁ b₁ a₂ b₂ t₁ t₂ irl₁ irl₂ eql := begin
  cases a₁; cases b₁; try { from false.elim irl₁ };
  cases a₂; cases b₂; try { from false.elim irl₂ <|> cases eql };
  simp only [is_restriction.name_lift] at eql,

  case name.extend { from ν₁_species.inj' M eql },
  case name.zero { from is_restriction.name_lift.inj_zero ℓ M A eql },
end

private def is_restriction.lift {Γ} (ℓ : lookup ℍ ω Γ) (M : affinity ℍ) (A : species ℍ ω (context.extend M.arity Γ))
  : is_restriction ℓ M A
  → transition.transition_from ℓ (ν(M) A)
| ⟨ ⟨ _, τ@' k, production.species B, t ⟩, _ ⟩ := begin
  have : τ@' k = label.rename (@name.extend Γ M.arity) (τ@' k), { simp only [label.rename] },
  from ⟨ _, _, _, ν₁_species M this t ⟩,
end
| ⟨ ⟨ _, τ⟨ p ⟩, production.species B, t ⟩, irl ⟩ := begin
  unfold is_restriction_like at irl,
  from upair.rec_on p
    (λ a b irl t, is_restriction.name_lift ℓ M A B a b irl t)
    (is_restriction.name_lift.comm ℓ M A B)
    irl t,
end
| ⟨ ⟨ _, # (name.zero n), E, t ⟩, irl ⟩ := false.elim irl
| ⟨ ⟨ _, # (name.extend n), production.concretion F, t ⟩, _ ⟩ := begin
  have : # (name.extend n) = label.rename (@name.extend Γ M.arity) (# n), { simp only [label.rename] },
  from ⟨ _, # n, production.concretion (ν'(M) F), ν₁_concretion M this t ⟩,
end

private def is_restriction.lift.inj_both {Γ : context} {ℓ : lookup ℍ ω Γ}
    (M : affinity ℍ) (A B : species ℍ ω (context.extend M.arity Γ)) :
  ∀ {B B' : species ℍ ω (context.extend M.arity Γ)}
    {p q : upair (name (context.extend M.arity Γ))}

    (t : A [lookup.rename name.extend ℓ, τ⟨ p ⟩]⟶ (production.species B))
    (irl : is_restriction_like ℓ M A ⟨kind.species, ⟨τ⟨ p ⟩, ⟨production.species B, t⟩⟩⟩)

    (t' : A [lookup.rename name.extend ℓ, τ⟨ q ⟩]⟶ (production.species B'))
    (irl' : is_restriction_like ℓ M A ⟨kind.species, ⟨τ⟨ q ⟩, ⟨production.species B', t'⟩⟩⟩)

  , is_restriction.lift ℓ M A ⟨⟨kind.species, ⟨τ⟨ p ⟩, ⟨production.species B, t⟩⟩⟩, irl⟩
  = is_restriction.lift ℓ M A ⟨⟨kind.species, ⟨τ⟨ q ⟩, ⟨production.species B', t'⟩⟩⟩, irl'⟩
  → (⟨⟨kind.species, ⟨τ⟨ p ⟩, ⟨production.species B, t⟩⟩⟩, irl⟩ : is_restriction ℓ M A)
  = ⟨⟨kind.species, ⟨τ⟨ q ⟩, ⟨production.species B', t'⟩⟩⟩, irl'⟩
| B B' p q t irl t' irl' eql := begin
  unfold is_restriction.lift at eql,
  rcases upair.exists_rep p with ⟨ a, b, ⟨ _ ⟩ ⟩,
  rcases upair.exists_rep q with ⟨ a', b', ⟨ _ ⟩ ⟩,

  simp only [],
  from is_restriction.name_lift.inj ℓ M A t t' irl irl' eql,
end

private def is_restriction.lift.inj {Γ} (ℓ : lookup ℍ ω Γ) (M : affinity ℍ) (A : species ℍ ω (context.extend M.arity Γ))
  : function.injective (is_restriction.lift ℓ M A)
| ⟨ ⟨ _, # (name.zero n), E, t ⟩, irl ⟩ _ eql := false.elim irl

| ⟨ ⟨ _, τ@' k, production.species B, t ⟩, _ ⟩ ⟨ ⟨ _, # (name.zero n), E, t' ⟩, irl ⟩ eql := false.elim irl
| ⟨ ⟨ _, τ@' k, production.species B, t ⟩, _ ⟩ ⟨ ⟨ _, τ@' k', production.species B', t' ⟩, _ ⟩ eql
  := by { cases ν₁_species.inj' M eql, from rfl }
| ⟨ ⟨ _, τ@' k, production.species B, t ⟩, _ ⟩ ⟨ ⟨ _, τ⟨ p ⟩, production.species B', t' ⟩, irl ⟩ eql := begin
  rcases upair.exists_rep p with ⟨ a, b, ⟨ _ ⟩ ⟩,
  simp only [is_restriction.lift, upair.rec_on_beta] at eql,
  cases a; cases b; cases eql <|> from false.elim irl,
end
| ⟨ ⟨ _, τ@' k, production.species B, t ⟩, _ ⟩ ⟨ ⟨ _, # (name.extend n), production.concretion F, t' ⟩, _ ⟩ eql := by cases eql

| ⟨ ⟨ _, τ⟨ p ⟩, production.species B, t ⟩, _ ⟩ ⟨ ⟨ _, # (name.zero n'), E, t' ⟩, irl ⟩ eql := false.elim irl
| ⟨ ⟨ _, τ⟨ p ⟩, production.species B, t ⟩, irl ⟩ ⟨ ⟨ _, # (name.extend n'), production.concretion F', t' ⟩, _ ⟩ eql := begin
  rcases upair.exists_rep p with ⟨ a, b, ⟨ _ ⟩ ⟩,
  simp only [is_restriction.lift, upair.rec_on_beta] at eql,
  cases a; cases b; cases eql <|> from false.elim irl,
end
| ⟨ ⟨ _, τ⟨ p ⟩, production.species B, t ⟩, irl ⟩ ⟨ ⟨ _, τ@' k', production.species B', t' ⟩, _ ⟩ eql := begin
  rcases upair.exists_rep p with ⟨ a, b, ⟨ _ ⟩ ⟩,
  simp only [is_restriction.lift, upair.rec_on_beta] at eql,
  cases a; cases b; cases eql <|> from false.elim irl,
end
| ⟨ ⟨ _, τ⟨ p ⟩, production.species B, t ⟩, irl ⟩ ⟨ ⟨ _, τ⟨ q ⟩, production.species B', t' ⟩, irl' ⟩ eql
  := is_restriction.lift.inj_both M A B t irl t' irl' eql

| ⟨ ⟨ _, # (name.extend n), production.concretion F, t ⟩, _ ⟩ ⟨ ⟨ _, # (name.extend n'), production.concretion F', t' ⟩, _ ⟩ eql
  := by { cases ν₁_concretion.inj' M eql, from rfl }
| ⟨ ⟨ _, # (name.extend n), production.concretion F, t ⟩, _ ⟩ ⟨ ⟨ _, # (name.zero n'), E, t' ⟩, irl ⟩ eql := false.elim irl
| ⟨ ⟨ _, # (name.extend n), production.concretion F, t ⟩, _ ⟩ ⟨ ⟨ _, τ@' k', production.species B', t' ⟩, _ ⟩ eql := by cases eql
| ⟨ ⟨ _, # (name.extend n), production.concretion F, t ⟩, _ ⟩ ⟨ ⟨ _, τ⟨ p ⟩, production.species B', t' ⟩, irl ⟩ eql := begin
  rcases upair.exists_rep p with ⟨ a, b, ⟨ _ ⟩ ⟩,
  simp only [is_restriction.lift, upair.rec_on_beta] at eql,
  cases a; cases b; cases eql <|> from false.elim irl,
end

private def is_restriction.embed {Γ} (ℓ : lookup ℍ ω Γ) (M : affinity ℍ) (A : species ℍ ω (context.extend M.arity Γ))
  : is_restriction ℓ M A
  ↪ transition.transition_from ℓ (ν(M) A)
  := ⟨ is_restriction.lift ℓ M A, is_restriction.lift.inj ℓ M A ⟩

instance is_restriction_name.decide {Γ} (M : affinity ℍ)
  : decidable_pred (λ (p : upair.pair (name (context.extend M.arity Γ))), is_restriction_name M p.fst p.snd)
| ⟨ name.zero a, name.zero b ⟩ := by { unfold is_restriction_name, apply_instance }
| ⟨ name.extend _, name.extend _ ⟩ := decidable.true
| ⟨ name.extend _, name.zero _ ⟩ := decidable.false
| ⟨ name.zero _, name.extend _ ⟩ := decidable.false

instance is_restriction_like.decide {Γ} (ℓ : lookup ℍ ω Γ) (M : affinity ℍ) (A : species ℍ ω (context.extend M.arity Γ))
  : decidable_pred (is_restriction_like ℓ M A)
| ⟨ _, τ⟨ p ⟩, E, t ⟩ := quot.lift.decidable_pred _ _ _
| ⟨ _, τ@' k, E, t ⟩ := decidable.true
| ⟨ _, # (name.zero n), E, t ⟩ := decidable.false
| ⟨ _, # (name.extend n), E, t ⟩ := decidable.true

private def enumerate_restriction {Γ} (ℓ : lookup ℍ ω Γ) (M : affinity ℍ) (A : species ℍ ω (context.extend M.arity Γ))
  : fintype (transition.transition_from (lookup.rename name.extend ℓ) A)
  → fintype (transition.transition_from ℓ (ν(M) A))
| As :=
  ⟨ finset.map (is_restriction.embed ℓ M A)
      (finset.subtype (is_restriction_like ℓ M A) As.elems)
  , λ t, begin
    rcases t with ⟨ k, α, E, t ⟩,
    cases t,
    case com₂ : p p' B k eql eqp t {
      rcases upair.exists_rep p with ⟨ a, b, ep' ⟩, subst ep',

      simp only [upair.map_beta] at eqp, subst eqp, cases eqp,

      have : is_restriction_like ℓ M A (transition_from.mk t),
      {
        show option.is_some' (M.f a b),
        have : M.f a b = some k := eql,
        rw this, from true.intro,
      },

      have kdef : k = option.get' this := option.some.inj (trans eql.symm (option.eq_some_of_is_some' this)),
      subst kdef,

      let t' : is_restriction ℓ M A := ⟨ ⟨ _, _, _, t ⟩, this ⟩,
      have this := finset.mem_map_of_mem (is_restriction.embed ℓ M A)
        (finset.mem_subtype.mpr (@fintype.complete _ As t'.val)),
      unfold_coes at this,
      simp only [is_restriction.embed, is_restriction.lift, upair.rec_on_beta, is_restriction.name_lift] at this,

      from this,
    },
    case ν₁_species : l l' B eql t {
      have : is_restriction_like ℓ M A (transition_from.mk t),
      {
        cases l; simp only [label.rename] at eql; subst eql;
        simp only [transition_from.mk, is_restriction_like],

        rcases upair.exists_rep l_k with ⟨ a, b, ⟨ _ ⟩ ⟩,
        from true.intro,
      },
      let t' : is_restriction ℓ M A := ⟨ ⟨ _, _, _, t ⟩, this ⟩,
      have this := finset.mem_map_of_mem (is_restriction.embed ℓ M A)
        (finset.mem_subtype.mpr (@fintype.complete _ As t'.val)),
      unfold_coes at this,

      cases l,
      case label.spontaneous { simp only [label.rename] at eql, subst eql, from this },

      have up : ∀ (a b : name Γ), (quot.mk setoid.r (upair.pair.mk a b)) = upair.mk a b := λ a b, rfl,
      rcases quot.exists_rep l_k with ⟨ ⟨ a, b ⟩, h ⟩, rw up at h, subst h,
      simp only [label.rename, upair.map_beta] at eql, subst eql,

      simp only [is_restriction.embed, is_restriction.lift, upair.rec_on_beta, is_restriction.name_lift] at this,
      from this,
    },
    case ν₁_concretion : l l' b y B eql t {
      cases l, simp only [label.rename] at eql, subst eql,
      let t' : is_restriction ℓ M A := ⟨ ⟨ _, _, _, t ⟩, true.intro ⟩,
      from finset.mem_map_of_mem (is_restriction.embed ℓ M A)
        (finset.mem_subtype.mpr (@fintype.complete _ As t'.val)),
    }
  end ⟩

/-- Show that the available transitions from a species is finite and thus
    enumerable.-/
def enumerate :
  ∀ {Γ} (ℓ : lookup ℍ ω Γ) (A : species ℍ ω Γ)
  , fintype (transition_from ℓ A)
| Γ ℓ nil := enumerate_nil
| Γ ℓ (apply D as) := enumerate_apply ℓ D as
| Γ ℓ (A |ₛ B) := enumerate_parallel (enumerate ℓ A) (enumerate ℓ B)
| Γ ℓ (Σ# As) := enumerate_choices ℓ As
| Γ ℓ (ν(M) A) := enumerate_restriction ℓ M A (enumerate (lookup.rename name.extend ℓ) A)
using_well_founded {
  rel_tac := λ _ _,
    `[exact ⟨_, measure_wf (λ x, whole.sizeof _ _ _ _ x.2.2 ) ⟩ ],
  dec_tac := tactic.fst_dec_tac,
}

instance {Γ} (ℓ : lookup ℍ ω Γ) (A : species ℍ ω Γ)
  : fintype (transition_from ℓ A) := enumerate ℓ A

end transition
end cpi

#lint-


import Smt.Reconstruction.Defs
import Smt.Reconstruction.Term

open Types
open proof
open term
open sort
open Nat

namespace Rules

syntax "absurdHyp" ident "(" ident,+ ")" : tactic
macro_rules
  | `(tactic| absurdHyp $h:ident ($n:ident)) => `(tactic| rewrite [($n)] at ($h); have z: False := ($h); cases z)
  | `(tactic| absurdHyp $h:ident ($n:ident, $m:ident)) => `(tactic| rewrite [($n), ($m)] at ($h); have z: False := ($h); simp at z)

open Classical

theorem notImplies1 : ∀ {t₁ t₂ : term},
  followsFrom (not $ implies t₁ t₂) t₁ :=
  by intros t₁ t₂ Γ Δ h
     simp at h
     split at h
     case h_1 _ k h' =>
       split at h'
       case h_1 _ k' h'' =>
         split at h''
         case h_1 _ k₁ k₂ rt₁ rt₂ =>
           simp
           rewrite [rt₁]
           have ek : (fun Γ Δ => ¬ k' Γ Δ) = k :=
             by injection h' with h'; injection h' with _ h'; exact h';
           have fe : (fun Γ Δ => k₁ Γ Δ → k₂ Γ Δ) = k' :=
             by injection h'' with h''; injection h'' with _ h''; exact h''
           rewrite [← ek, ← fe] at h
           apply byContradiction
           exact (λ hf => h (λ k₁w => False.elim (hf k₁w)))
         case h_2 => simp at h''
       case h_2 => simp at h'
     case h_2 => exact (False.elim h)

theorem notImplies2 : ∀ {t₁ t₂ : term},
  followsFrom (not $ implies t₁ t₂) (not t₂) :=
    by intros t₁ t₂ Γ Δ h
       simp at h
       match r₁: interpTerm t₁, r₂: interpTerm t₂ with
       | some ⟨ atom 1, k₁ ⟩, some ⟨ atom 1, k₂ ⟩ =>
           simp
           rewrite [r₂]
           show ¬ k₂ Γ Δ
           rewrite [r₁, r₂] at h
           have h₂ : ¬ ((k₁ Γ Δ) → (k₂ Γ Δ)) := h
           match em (k₂ Γ Δ) with
           | Or.inl r  => exact False.elim (h₂ (λ _ => r))
           | Or.inr r  => exact r
       | some ⟨ atom 0, _ ⟩, _  => rewrite [r₁] at h; simp at h
       | some ⟨ atom 1, k₁ ⟩, some ⟨ atom 0, _ ⟩  => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ atom (succ (succ _)), _ ⟩ => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ sort.undef, _ ⟩           => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ sort.array _ _, _ ⟩       => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ sort.bv _, _ ⟩            => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ sort.arrow _ _, _ ⟩       => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ sort.dep, _ ⟩             => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, none                             => absurdHyp h (r₁, r₂)
       | some ⟨ atom (succ (succ _)), _ ⟩, _ => absurdHyp h (r₁)
       | some ⟨ sort.undef, _ ⟩, _           => absurdHyp h (r₁)
       | some ⟨ sort.array _ _, _ ⟩, _       => absurdHyp h (r₁)
       | some ⟨ sort.bv _, _ ⟩, _            => absurdHyp h (r₁)
       | some ⟨ sort.arrow _ _, _ ⟩, _       => absurdHyp h (r₁)
       | some ⟨ sort.dep, _ ⟩, _             => absurdHyp h (r₁)
       | none, _                             => absurdHyp h (r₁)

theorem impliesElim : ∀ {t₁ t₂ : term},
  followsFrom (implies t₁ t₂) (or (not t₁) t₂)
  | t₁, t₂, Γ, Δ, h =>
    by simp at h
       match r₁: interpTerm t₁, r₂: interpTerm t₂ with
       | some ⟨ atom 1, k₁ ⟩, some ⟨ atom 1, k₂ ⟩ =>
           simp
           rewrite [r₁, r₂]
           rewrite [r₁, r₂] at h
           show (¬ k₁ Γ Δ) ∨ (k₂ Γ Δ)
           have h₂ : k₁ Γ Δ → k₂ Γ Δ := h
           match em (k₁ Γ Δ), em (k₂ Γ Δ) with
           | Or.inl _, Or.inl k₂W => exact Or.inr k₂W
           | Or.inl k₁W, Or.inr nk₂W => have k₂W := h₂ k₁W
                                        exact (False.elim (nk₂W k₂W))
           | Or.inr _, Or.inl k₂W => exact Or.inr k₂W
           | Or.inr nk₁W, Or.inr _ => exact Or.inl nk₁W
       | some ⟨ atom 0, _ ⟩, _  => absurdHyp h (r₁)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ atom 0, _ ⟩  => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ atom (succ (succ _)), _ ⟩ => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ sort.undef, _ ⟩           => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ sort.array _ _, _ ⟩       => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ sort.bv _, _ ⟩            => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ sort.arrow _ _, _ ⟩       => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, some ⟨ sort.dep, _ ⟩             => absurdHyp h (r₁, r₂)
       | some ⟨ atom 1, k₁ ⟩, none                             => absurdHyp h (r₁, r₂)
       | some ⟨ atom (succ (succ _)), _ ⟩, _ => absurdHyp h (r₁)
       | some ⟨ sort.undef, _ ⟩, _           => absurdHyp h (r₁)
       | some ⟨ sort.array _ _, _ ⟩, _       => absurdHyp h (r₁)
       | some ⟨ sort.bv _, _ ⟩, _            => absurdHyp h (r₁)
       | some ⟨ sort.arrow _ _, _ ⟩, _       => absurdHyp h (r₁)
       | some ⟨ sort.dep, _ ⟩, _             => absurdHyp h (r₁)
       | none, _                             => absurdHyp h (r₁)

theorem contradiction: ∀ {t: term},
  followsFrom (and (not t) t) bot
  | t, Γ, Δ, h => by
    simp at h
    match r: interpTerm t with
    | some ⟨ atom 1, k ⟩ =>
        rewrite [r] at h;
        simp at h
        have ⟨nkW, kW⟩ : ¬ (k Γ Δ) ∧ k Γ Δ := h
        exact False.elim (nkW kW)
    | some ⟨ atom 0, _ ⟩               => absurdHyp h (r)
    | some ⟨ atom (succ (succ _)), _ ⟩ => absurdHyp h (r)
    | some ⟨ sort.undef, _ ⟩           => absurdHyp h (r)
    | some ⟨ sort.array _ _, _ ⟩       => absurdHyp h (r)
    | some ⟨ sort.bv _, _ ⟩            => absurdHyp h (r)
    | some ⟨ sort.arrow _ _, _ ⟩       => absurdHyp h (r)
    | some ⟨ sort.dep, _ ⟩             => absurdHyp h (r)
    | none                             => absurdHyp h (r)

theorem R1 : ∀ {t₁ t₂ : term},
  followsFrom (and (or (not t₁) t₂) t₁) t₂
  | t₁, t₂, Γ, Δ, h => by
    simp at h
    match r₁: interpTerm t₁, r₂: interpTerm t₂ with
    | some ⟨ atom 1, k₁ ⟩, some ⟨ atom 1, k₂ ⟩ =>
        simp at *
        rewrite [r₁, r₂] at h
        rewrite [r₂]
        have ⟨ H, k₁W ⟩: ((¬ (k₁ Γ Δ)) ∨ (k₂ Γ Δ)) ∧ (k₁ Γ Δ) := h
        match em (k₂ Γ Δ) with
        | Or.inl k₂W  => exact k₂W
        | Or.inr _    => match em (k₁ Γ Δ) with
                         | Or.inl k₁W  => match H with
                                          | Or.inl nk₁W => exact (False.elim (nk₁W k₁W))
                                          | Or.inr k₂W  => exact k₂W
                         | Or.inr nk₁W => exact (False.elim (nk₁W k₁W))
    | some ⟨ atom 1, _ ⟩, some ⟨ atom 0, _ ⟩               => absurdHyp h (r₁, r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ atom (succ (succ _)), _ ⟩ => absurdHyp h (r₁, r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ sort.undef, _ ⟩           => absurdHyp h (r₁, r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ sort.array _ _, _ ⟩       => absurdHyp h (r₁, r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ sort.bv _, _ ⟩            => absurdHyp h (r₁, r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ sort.arrow _ _, _ ⟩       => absurdHyp h (r₁, r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ sort.dep, _ ⟩             => absurdHyp h (r₁, r₂)
    | some ⟨ atom 1, _ ⟩, none                             => absurdHyp h (r₁, r₂)
    | some ⟨ atom 0, _ ⟩, _               => absurdHyp h (r₁)
    | some ⟨ atom (succ (succ _)), _ ⟩, _ => absurdHyp h (r₁)
    | some ⟨ sort.undef, _ ⟩, _           => absurdHyp h (r₁)
    | some ⟨ sort.array _ _, _ ⟩, _       => absurdHyp h (r₁)
    | some ⟨ sort.bv _, _ ⟩, _            => absurdHyp h (r₁)
    | some ⟨ sort.arrow _ _, _ ⟩, _       => absurdHyp h (r₁)
    | some ⟨ sort.dep, _ ⟩, _             => absurdHyp h (r₁)
    | none, _                             => absurdHyp h (r₁)

theorem conjunction: ∀ {t₁ t₂: term} {Γ: Environment} {Δ : SEnvironment},
  validWith Γ Δ t₁ → validWith Γ Δ t₂ → validWith Γ Δ (and t₁ t₂)
  | t₁, t₂, Γ, Δ, h₁, h₂ => by
    simp at *
    match r₁: interpTerm t₁, r₂: interpTerm t₂ with
    | some ⟨ atom 1, k₁ ⟩, some ⟨ atom 1, k₂ ⟩ =>
        show (k₁ Γ Δ) ∧ (k₂ Γ Δ)
        simp
        rewrite [r₁] at h₁
        rewrite [r₂] at h₂
        have k₁W: (k₁ Γ Δ) := h₁
        have k₂W: (k₂ Γ Δ) := h₂
        exact And.intro k₁W k₂W
    | some ⟨ atom 1, _ ⟩, some ⟨ atom 0, _ ⟩               => absurdHyp h₂ (r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ atom (succ (succ _)), _ ⟩ => absurdHyp h₂ (r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ sort.undef, _ ⟩           => absurdHyp h₂ (r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ sort.array _ _, _ ⟩       => absurdHyp h₂ (r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ sort.bv _, _ ⟩            => absurdHyp h₂ (r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ sort.arrow _ _, _ ⟩       => absurdHyp h₂ (r₂)
    | some ⟨ atom 1, _ ⟩, some ⟨ sort.dep, _ ⟩             => absurdHyp h₂ (r₂)
    | some ⟨ atom 1, _ ⟩, none                             => absurdHyp h₂ (r₂)
    | some ⟨ atom 0, _ ⟩, _                                => absurdHyp h₁ (r₁)
    | some ⟨ atom (succ (succ _)), _ ⟩ , _ => absurdHyp h₁ (r₁)
    | some ⟨ sort.undef, _ ⟩, _            => absurdHyp h₁ (r₁)
    | some ⟨ sort.array _ _, _ ⟩, _        => absurdHyp h₁ (r₁)
    | some ⟨ sort.bv _, _ ⟩, _             => absurdHyp h₁ (r₁)
    | some ⟨ sort.arrow _ _, _ ⟩, _        => absurdHyp h₁ (r₁)
    | some ⟨ sort.dep, _ ⟩, _              => absurdHyp h₁ (r₁)
    | none, _                              => absurdHyp h₁ (r₁)

theorem followsBot: ∀ {t: term},
  followsFrom t bot → ∀ {Γ : Environment} {Δ : SEnvironment}, ¬ validWith Γ Δ t
  | t, h, Γ, Δ => by
    intro validT
    have validBot := @h Γ Δ validT
    simp at validBot
    cases validBot

@[simp] def isBool : term → Bool
  | t => match interpTerm t with
         | some ⟨ atom 1, _ ⟩ => true
         | _ => false

theorem interpNotTerm: ∀ {Γ: Environment} {Δ: SEnvironment} {t: term},
  isBool t → ¬ validWith Γ Δ (not t) → validWith Γ Δ t
  | Γ, Δ, t, bt, h => by
    simp
    match r: interpTerm t with
    | some ⟨ atom 1, k ⟩ => match em (k Γ Δ) with
                            | Or.inl kW  => exact kW
                            | Or.inr nkW => simp at h
                                            rewrite [r] at h
                                            have nnkW : ¬ (¬ (k Γ Δ)) := h
                                            exact (False.elim (nnkW nkW))
    | some ⟨ atom 0, _ ⟩               => simp at bt; rewrite [r] at bt; cases bt
    | some ⟨ atom (succ (succ _)), _ ⟩ => simp at bt; rewrite [r] at bt; cases bt
    | some ⟨ sort.undef, _ ⟩           => simp at bt; rewrite [r] at bt; cases bt
    | some ⟨ sort.array _ _, _ ⟩       => simp at bt; rewrite [r] at bt; cases bt
    | some ⟨ sort.bv _, _ ⟩            => simp at bt; rewrite [r] at bt; cases bt
    | some ⟨ sort.arrow _ _, _ ⟩       => simp at bt; rewrite [r] at bt; cases bt
    | some ⟨ sort.dep, _ ⟩             => simp at bt; rewrite [r] at bt; cases bt
    | none                             => simp at bt; rewrite [r] at bt; cases bt

end Rules


structure X := ( a : Type )
definition x : X := { a := unit }
definition y : X := { a := unit }
lemma t : x^.a = unit := begin
                           dsimp [ y ],
                           dsimp [ x ],
                           refl
                         end


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

Properties of the multivariate Gaussian distribution.
-/
import .tfacts .tgrads

namespace certigrad
namespace T

axiom is_integrable_mvn_of_sub_exp {shape₁ shape₂ : S} (μ σ : T shape₁) (f : T shape₁ → T shape₂) :
  is_btw_exp₂ f → is_integrable (λ x, mvn_pdf μ σ x ⬝ f x)

axiom is_uintegrable_mvn_of_bounded_exp₂_around {shape₁ shape₂ shape₃ : S} (pdf : T shape₁ → ℝ) (f : T shape₁ → T shape₂ → T shape₃) (θ : T shape₂) :
  is_bounded_btw_exp₂_around f θ → is_uniformly_integrable_around (λ θ₀ x, pdf x ⬝ f x θ₀) θ

end T

section tactic
open tactic

meta def prove_is_mvn_integrable_core : tactic unit :=
first [
       applyc `certigrad.T.is_btw_id
     , applyc `certigrad.T.is_btw_const
     , applyc `certigrad.T.is_btw_sigmoid
     , applyc `certigrad.T.is_btw_softplus
     , applyc `certigrad.T.is_btw_sum
     , applyc `certigrad.T.is_btw_log_sigmoid
     , applyc `certigrad.T.is_btw_log_1msigmoid
     , applyc `certigrad.T.is_btw_gemm
     , applyc `certigrad.T.is_btw_transpose
     , applyc `certigrad.T.is_btw_neg
     , applyc `certigrad.T.is_btw_inv
     , applyc `certigrad.T.is_btw_add
     , applyc `certigrad.T.is_btw_mul
     , applyc `certigrad.T.is_btw_sub
     , applyc `certigrad.T.is_btw_div
     , applyc `certigrad.T.is_btw_exp

     , applyc `certigrad.T.is_sub_quadratic_id
     , applyc `certigrad.T.is_sub_quadratic_const
     , applyc `certigrad.T.is_sub_quadratic_gemm
     , applyc `certigrad.T.is_sub_quadratic_transpose
     , applyc `certigrad.T.is_sub_quadratic_neg
     , applyc `certigrad.T.is_sub_quadratic_add
     , applyc `certigrad.T.is_sub_quadratic_softplus
     , applyc `certigrad.T.is_sub_quadratic_mul₁
     , applyc `certigrad.T.is_sub_quadratic_mul₂
     , applyc `certigrad.T.is_sub_quadratic_sub
     , prove_preconditions_core
]

meta def prove_is_mvn_integrable : tactic unit :=
do applyc `certigrad.T.is_integrable_mvn_of_sub_exp,
   repeat prove_is_mvn_integrable_core

meta def prove_is_mvn_uintegrable_core_helper : tactic unit :=
first [applyc `certigrad.T.is_bbtw_of_btw
     , applyc `certigrad.T.is_bbtw_id
     , applyc `certigrad.T.is_bbtw_bernoulli_neglogpdf
     , applyc `certigrad.T.is_bbtw_softplus
     , applyc `certigrad.T.is_bbtw_sum
     , applyc `certigrad.T.is_bbtw_log_sigmoid
     , applyc `certigrad.T.is_bbtw_log_1msigmoid
     , applyc `certigrad.T.is_bbtw_gemm
     , applyc `certigrad.T.is_bbtw_neg
     , applyc `certigrad.T.is_bbtw_inv
     , applyc `certigrad.T.is_bbtw_mul
     , applyc `certigrad.T.is_bbtw_sub
     , applyc `certigrad.T.is_bbtw_add
     , applyc `certigrad.T.is_bbtw_exp
] <|> (intro1 >> skip)

meta def prove_is_mvn_uintegrable_core : tactic unit :=
do try T.simplify_grad,
   applyc `certigrad.T.is_uintegrable_mvn_of_bounded_exp₂_around,
   repeat (prove_is_mvn_uintegrable_core_helper <|> prove_is_mvn_integrable_core)

meta def prove_is_mvn_uintegrable : tactic unit :=
-- TODO(dhs): why do I need the `try`?
(split >> focus [prove_is_mvn_uintegrable, prove_is_mvn_uintegrable]) <|> try prove_is_mvn_uintegrable_core

end tactic

namespace T
axiom mvn_const_int {shape oshape : S} (μ σ : T shape) : σ > 0 → ∀ (y : T oshape), is_integrable (λ (x : T shape), mvn_pdf μ σ x ⬝ y)
axiom mvn_moment₁_int {shape : S} (μ σ : T shape) : σ > 0 → is_integrable (λ (x : T shape), mvn_pdf μ σ x ⬝ x)
axiom mvn_moment₂_int {shape : S} (μ σ : T shape) : σ > 0 → is_integrable (λ (x : T shape), mvn_pdf μ σ x ⬝ square x)
axiom mvn_cmoment₂_int {shape : S} (μ σ : T shape) (H_σ : σ > 0) : is_integrable (λ (x : T shape), T.mvn_pdf μ σ x ⬝ square (x - μ))

axiom mvn_logpdf_int {shape : S} (μ μ' σ σ' : T shape) (H_σ : σ > 0) (H_σ' : σ' > 0) : is_integrable (λ (x : T shape), T.mvn_pdf μ σ x ⬝ mvn_logpdf μ' σ' x)

-- TODO(dhs): prove in terms of primitives (possibly for concrete p)
axiom mvn_bernoulli_neglogpdf_int {shape₁ shape₂ : S} (μ σ : T shape₁) (H_σ : σ > 0) (p : T shape₁ → T shape₂)
                                      (H_p_cont : ∀ x, is_continuous p x) (H_p : ∀ x, p x > 0 ∧ p x < 1) (z : T shape₂) :
  is_integrable (λ (x : T shape₁), T.mvn_pdf μ σ x ⬝ bernoulli_neglogpdf (p x) z)

axiom mvn_mvn_empirical_kl_int {shape : S} (μ σ : T shape) (H_σ : σ > 0) (μ' σ' : T shape) :
  is_integrable (λ (x : T shape), T.mvn_pdf μ σ x ⬝ mvn_empirical_kl μ' σ' x)

axiom mvn_mvn_kl_int {shape : S} (μ σ : T shape) (H_σ : σ > 0) (μ' σ' : T shape) :
  is_integrable (λ (x : T shape), T.mvn_pdf μ σ x ⬝ mvn_kl μ' σ')

-- mvn is a distribution (provable from first principles)
axiom mvn_pdf_pos {shape : S} (μ σ : T shape) : σ > 0 → ∀ (x : T shape), mvn_pdf μ σ x > 0
axiom mvn_pdf_int1 {shape : S} (μ σ : T shape) : σ > 0 → ∫ (λ (x : T shape), mvn_pdf μ σ x) = 1

lemma mvn_expected {shape oshape : S} (μ σ : T shape) : σ > 0 → ∀ (y : T oshape), ∫ (λ (x : T shape), mvn_pdf μ σ x ⬝ y) = y :=
by { intros H_σ y, rw [integral_fscale, (mvn_pdf_int1 _ _ H_σ), one_smul] }

-- moments (provable from first principles)
axiom mvn_moment₁ {shape : S} (μ σ : T shape) (H_σ : σ > 0) : ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ x) = μ
axiom mvn_moment₂ {shape : S} (μ σ : T shape) (H_σ : σ > 0) : ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ square x) = square μ + square σ

-- central moments (provable in terms of moments)
lemma mvn_cmoment₁ {shape : S} (μ σ : T shape) (H_σ : σ > 0) : ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ (x - μ)) = 0 :=
have H_int_x : is_integrable (λ x, mvn_pdf μ σ x ⬝ x), from mvn_moment₁_int μ σ H_σ,
have H_int_μ : is_integrable (λ x, - (mvn_pdf μ σ x ⬝ μ)), from iff.mp (is_integrable_neg _) (mvn_const_int μ σ H_σ μ),
calc  ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ (x - μ))
    = ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ x + - (T.mvn_pdf μ σ x ⬝ μ)) : begin simp [smul_addr, smul_neg], end
... = ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ x) - ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ μ)
        : begin simp [integral_add, H_int_x, H_int_μ, integral_neg] end
... = μ - μ : by { rw [mvn_expected _ _ H_σ, mvn_moment₁ _ _ H_σ],  }
... = 0 : by simp

-- Exercise for the reader: prove
axiom mvn_cmoment₂ {shape : S} (μ σ : T shape) (H_σ : σ > 0) : ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ square (x - μ)) = square σ

-- central scaled moments (provable in terms of central moments)
lemma mvn_csmoment₁ {shape : S} (μ σ : T shape) (H_σ : σ > 0) : ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ ((x - μ) / σ)) = 0 :=
have H_int_xσ : is_integrable (λ (x : T shape), T.mvn_pdf μ σ x ⬝ (x / σ)),
  by { simp [smul_div], exact iff.mp (is_integrable_div _ _ H_σ) (mvn_moment₁_int _ _ H_σ) },

have H_int_μσ : is_integrable (λ (x : T shape), -(T.mvn_pdf μ σ x ⬝ (μ / σ))),
 by { apply iff.mp (is_integrable_neg _), simp [smul_div], exact iff.mp (is_integrable_div _ _ H_σ) (mvn_const_int _ _ H_σ _) },

calc  ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ ((x - μ) / σ))
    = ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ (x / σ) - (T.mvn_pdf μ σ x ⬝ (μ / σ)))
        : by simp [T.div_add_div_same_symm, smul_addr, sum_add, neg_div, smul_neg, integral_neg]
... = ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ (x / σ)) - ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ (μ / σ))
        : begin simp [integral_add, H_int_xσ, H_int_μσ, integral_neg] end
... = ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ x) / σ - ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ (μ / σ))
        : by simp [smul_div, integral_div]
... = μ / σ - μ / σ : by rw [mvn_moment₁ _ _ H_σ, mvn_expected _ _ H_σ]
... = 0 : by simp

-- Exercise for the reader: prove
axiom mvn_csmoment₂ {shape : S} (μ σ : T shape) (H_σ : σ > 0) : ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ square ((x - μ) / σ)) = (1 : T shape)

lemma mvn_logpdf_correct {shape : S} (μ σ x : T shape) (H_σ : σ > 0) : log (mvn_pdf μ σ x) = mvn_logpdf μ σ x :=
have H_σ₂ : square σ > 0, from square_pos_of_pos H_σ,
have H_mul : (2 * pi shape) * square σ > 0, from mul_pos_of_pos_pos two_pi_pos H_σ₂,
have H_sqrt : (sqrt ((2 * pi shape) * square σ))⁻¹ > 0, from inv_pos (sqrt_pos H_mul),
have H_exp : exp ((- 2⁻¹) * (square $ (x - μ) / σ)) > 0, from exp_pos,
have H_mul₂ : (sqrt ((2 * pi shape) * square σ))⁻¹ * exp ((- 2⁻¹) * (square $ (x - μ) / σ)) > 0,
from mul_pos_of_pos_pos H_sqrt H_exp,
calc  log (mvn_pdf μ σ x)
    = log (prod ((sqrt ((2 * pi shape) * square σ))⁻¹ * exp ((- 2⁻¹) * (square $ (x - μ) / σ)))) : rfl
... = sum (log ((sqrt ((2 * pi shape) * square σ))⁻¹) + ((- 2⁻¹) * (square $ (x - μ) / σ))) : by simp only [log_prod H_mul₂, log_mul H_sqrt H_exp, log_exp]
... = sum ((- 2⁻¹) * log ((2 * pi shape) * square σ) + ((- 2⁻¹) * (square $ (x - μ) / σ))) : by simp [log_inv, log_sqrt]
... = sum ((- 2⁻¹) * (log (2 * pi shape) + log (square σ)) + (- 2⁻¹) * (square $ (x - μ) / σ)) : by simp only [log_mul two_pi_pos H_σ₂]
... = sum ((- 2⁻¹) * (log (2 * pi shape) + log (square σ) + (square $ (x - μ) / σ))) : by simp only [left_distrib]
... = sum ((- (2 : ℝ)⁻¹) ⬝ (log (2 * pi shape) + log (square σ) + (square $ (x - μ) / σ))) : by simp only [smul.def, const_neg, const_inv, const_bit0, const_one]
... = (- 2⁻¹) * sum (square ((x - μ) / σ) + log (2 * pi shape) + log (square σ)) : by simp [sum_smul]
... = mvn_logpdf μ σ x : rfl

lemma mvn_int_const {shape : S} (μ σ : T shape) (H_σ : σ > 0) (y : ℝ) :
  ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ y) = y :=
by { rw [integral_fscale, (mvn_pdf_int1 _ _ H_σ), one_smul] }

lemma mvn_integral₁ {shape : S} (μ σ : T shape) (H_σ : σ > 0) :
∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ T.mvn_logpdf 0 1 x)
=
(- 2⁻¹) * sum (square μ + square σ) + (- 2⁻¹) * sum (log (2 * pi shape)) :=
have H_sq_x_int : is_integrable (λ (x : T shape), T.mvn_pdf μ σ x ⬝ square x), from mvn_moment₂_int _ _ H_σ,
have H_log_pi_int : is_integrable (λ (x : T shape), T.mvn_pdf μ σ x ⬝ log (2 * pi shape)), from mvn_const_int _ _ H_σ _,
have H_sum_int : is_integrable (λ (x : T shape), T.mvn_pdf μ σ x ⬝ (square x + log (2 * pi shape))),
  begin simp only [smul_addr], exact iff.mp (is_integrable_add _ _) (and.intro H_sq_x_int H_log_pi_int) end,
calc  ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ ((- 2⁻¹) * sum (square ((x - 0) / 1) + log (2 * pi shape) + log (square 1))))
    = ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ ((- 2⁻¹) * sum (square x + log (2 * pi shape)))) : by simp [log_one, square, T.div_one]
... = ∫ (λ (x : T shape), (- (2 : ℝ)⁻¹) ⬝ (T.mvn_pdf μ σ x ⬝ sum (square x + log (2 * pi shape)))) : by simp only [smul_mul_scalar_right]
... = (- 2⁻¹) * ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ sum (square x + log (2 * pi shape))) : by { simp only [integral_scale], simp [smul.def] }
... = (- 2⁻¹) * sum (∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ (square x + log (2 * pi shape)))) : by { simp only [integral_sum, H_sum_int, smul_sum] }
... = (- 2⁻¹) * sum (∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ square x + T.mvn_pdf μ σ x ⬝ log (2 * pi shape))) : by { simp only [smul_addr] }
... = (- 2⁻¹) * sum (∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ square x) + ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ log (2 * pi shape)))
       : by { simp only [integral_add, H_sq_x_int, H_log_pi_int] }
... = (- 2⁻¹) * (sum (square μ + square σ) + sum (log (2 * pi shape))) : by rw [mvn_moment₂ _ _ H_σ, mvn_expected _ _ H_σ, sum_add]
... = (- 2⁻¹) * sum (square μ + square σ) + (- 2⁻¹) * sum (log (2 * pi shape)) : by rw left_distrib

lemma mvn_integral₂ {shape : S} (μ σ : T shape) (H_σ : σ > 0) :
∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ T.mvn_logpdf μ σ x)
=
(- 2⁻¹) * sum (1 : T shape) + (- 2⁻¹) * sum (log (2 * pi shape)) + (- 2⁻¹) * sum (log (square σ)) :=
have H_int₁ : is_integrable (λ (x : T shape), mvn_pdf μ σ x ⬝ (-2⁻¹ * sum (square ((x - μ) / σ)))),
begin
simp only [smul_mul_scalar_right, integral_scale],
apply iff.mp (is_integrable_scale _ _),
simp only [smul_sum],
apply iff.mp (is_integrable_sum _),
simp only [square_div, smul_div],
apply iff.mp (is_integrable_div _ _ (square_pos_of_pos H_σ)),
exact mvn_cmoment₂_int _ _ H_σ,
end,

have H_int₂ : is_integrable (λ (x : T shape), mvn_pdf μ σ x ⬝ (-2⁻¹ * sum (log (2 * pi shape)))),
begin
simp only [smul_mul_scalar_right, integral_scale],
apply iff.mp (is_integrable_scale _ _),
simp only [smul_sum],
apply iff.mp (is_integrable_sum _),
exact mvn_const_int _ _ H_σ _
end,

have H_int₁₂ : is_integrable (λ (x : T shape), mvn_pdf μ σ x ⬝ (-2⁻¹ * sum (square ((x - μ) / σ))) + mvn_pdf μ σ x ⬝ (-2⁻¹ * sum (log (2 * pi shape)))),
from iff.mp (is_integrable_add _ _) (and.intro H_int₁ H_int₂),

have H_int₃ : is_integrable (λ (x : T shape), mvn_pdf μ σ x ⬝ (-2⁻¹ * sum (log (square σ)))),
begin
simp only [smul_mul_scalar_right, integral_scale],
apply iff.mp (is_integrable_scale _ _),
simp only [smul_sum],
apply iff.mp (is_integrable_sum _),
exact mvn_const_int _ _ H_σ _
end,

have H_int₄ : is_integrable (λ (x : T shape), T.mvn_pdf μ σ x ⬝ square ((x - μ) / σ)),
begin
simp only [square_div, smul_div],
apply iff.mp (is_integrable_div _ _ (square_pos_of_pos H_σ)),
exact mvn_cmoment₂_int _ _ H_σ,
end,

have H₁ : ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ ((- 2⁻¹) * sum (square ((x - μ) / σ)))) = (- 2⁻¹) * sum (1 : T shape), from
calc  ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ ((- 2⁻¹) * sum (square ((x - μ) / σ))))
    = ∫ (λ (x : T shape), (- (2 : ℝ)⁻¹) ⬝ (T.mvn_pdf μ σ x ⬝ sum (square ((x - μ) / σ)))) : by simp only [smul_mul_scalar_right]
... = (- 2⁻¹) * ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ sum (square ((x - μ) / σ))) : by { simp only [integral_scale], simp [smul.def] }
... = (- 2⁻¹) * sum (∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ square ((x - μ) / σ))) : by simp only [smul_sum, integral_sum, H_int₄]
... = (- 2⁻¹) * sum (1 : T shape) : by rw (mvn_csmoment₂ _ _ H_σ),

have H₂ : ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ ((- 2⁻¹) * sum (log (2 * pi shape)))) = (- 2⁻¹) * sum (log (2 * pi shape)), by rw (mvn_int_const μ _ H_σ),

have H₃ : ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ ((- 2⁻¹) * sum (log (square σ)))) = (- 2⁻¹) * sum (log (square σ)), by rw mvn_int_const μ _ H_σ,
begin
dunfold mvn_logpdf,
simp only [sum_add, left_distrib, smul_addr, integral_add, H₁, H₂, H₃, H_int₁₂, H_int₁, H_int₂, H_int₃],
end

lemma mvn_kl_identity {shape : S} (μ σ : T shape) (H_σ : σ > 0) :
∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ T.mvn_empirical_kl μ σ x)
=
T.mvn_kl μ σ :=
have H_logpdf_int : is_integrable (λ (x : T shape), T.mvn_pdf μ σ x ⬝ mvn_logpdf μ σ x),
from mvn_logpdf_int μ μ σ σ H_σ H_σ,

have H_std_logpdf_int : is_integrable (λ (x : T shape), - (T.mvn_pdf μ σ x ⬝ mvn_logpdf 0 1 x)),
from iff.mp (is_integrable_neg _) (mvn_logpdf_int μ 0 σ 1 H_σ one_pos),

calc  ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ T.mvn_empirical_kl μ σ x)
    = ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ (mvn_logpdf μ σ x - mvn_logpdf 0 1 x)) : rfl
... = ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ mvn_logpdf μ σ x + - (T.mvn_pdf μ σ x ⬝ mvn_logpdf 0 1 x)) : by simp [smul_addr, smul_neg]
... = ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ mvn_logpdf μ σ x) - ∫ (λ (x : T shape), T.mvn_pdf μ σ x ⬝ mvn_logpdf 0 1 x)
      : by simp [integral_add, H_logpdf_int, H_std_logpdf_int, integral_neg]
... = ((- 2⁻¹) * sum (1 : T shape) + (- 2⁻¹) * sum (log (2 * pi shape)) + (- 2⁻¹) * sum (log (square σ))) - ((- 2⁻¹) * sum (square μ + square σ) + (- 2⁻¹) * sum (log (2 * pi shape))) : by rw [mvn_integral₁ μ σ H_σ, mvn_integral₂ μ σ H_σ]
... = (- 2⁻¹) * sum ((1 : T shape) + log (2 * pi shape) + log (square σ) - square μ - square σ - log (2 * pi shape)) : by simp [sum_add, left_distrib, sum_neg]
... = (- 2⁻¹) * sum ((1 : T shape) + log (square σ) - square μ - square σ + (log (2 * pi shape) - log (2 * pi shape))) : by simp
... = (- 2⁻¹) * sum ((1 : T shape) + log (square σ) - square μ - square σ) : by simp
... = T.mvn_kl μ σ : rfl

end T
end certigrad


import aux
import parlang.def
import parlang.lemmas_exec
import data.bool

namespace parlang

variables {σ : Type} {ι : Type} {τ : ι → Type} [decidable_eq ι]

/-

    because this holds for all n and ac the pre- and postcondition probably contain ite or forall quantifiers
-/
def hoare (P : thread_state σ τ → Prop) (k : kernel σ τ) (Q : thread_state σ τ → Prop) : Prop :=
∀ {n} {s u : state n σ τ} {ac : vector bool n}, (∀i : fin n, ac.nth i → P (s.threads.nth i)) → exec_state k ac s u → (∀i : fin n, ac.nth i → Q (u.threads.nth i))

notation `{* ` P : 1 ` *} ` k : 1 ` {* ` Q : 1 ` *}` := hoare P k Q

example (P Q : thread_state σ τ → Prop) (k₁ k₂ : kernel σ τ) (c : σ → bool) :
    {* λ (t : thread_state σ τ), P t ∧ c t.tlocal *} k₁ {* Q *} → -- how is it possible that by loosening up the assumptions (i. e. and something to P) the proof gets possible?
    {* λ (t : thread_state σ τ), P t ∧ ¬c t.tlocal *} k₂ {* Q *} →
    {* P *} kernel.ite c k₁ k₂ {* Q *} :=
begin
    intros h_then h_else n s u ac hp he i hac,
    cases he,
    have : _ := exec_state_comm_distinct_ac _ he_a he_a_1,
    cases this with t' this,
    -- we reorder the execution (and state transition respectively) to macht the hoare triplets using exec_state_comm_distinct_ac
    -- either the condition holds or not for any thread i
    -- ?? in either case we have to go through both executions ??
    by_cases hc : (c (vector.nth (s.threads) i).tlocal = tt),
    {
        apply h_then,
        tactic.swap,
        exact this.right,
        intros i' hh,
        have hh' : _ := deactivate_threads_alive hh,
        have heqst' : vector.nth (s.threads) i' = vector.nth (t'.threads) i' := begin
            apply exec_state_inactive_threads_untouched this.left,
            apply deactivate_threads_complement hh,
        end,
        rw ← heqst',
        apply and.intro,
        {
            exact hp i' hh',
        }, {
            exact deactivate_threads_condition hh,
        }, {
            apply active_map_deactivate_threads hac (bool.eq_tt_coe.mpr hc),
        },
    }, {
        apply h_else,
        tactic.swap,
        exact he_a_1,
        intros i' hh,
        have hh' : _ := deactivate_threads_alive hh,
        have heqst' : vector.nth (s.threads) i' = vector.nth (he_t.threads) i' := begin
            apply exec_state_inactive_threads_untouched he_a,
            apply deactivate_threads_complement,
            rw bool.bnot_bnot,
            exact hh,
        end,
        rw ← heqst',
        apply and.intro,
        {
            exact hp i' hh',
        }, {
            exact deactivate_threads_condition' hh,
        }, {
            rw ← bool.eq_tt_coe at hc,
            apply active_map_deactivate_threads' hac hc,
        }
    }, {
        sorry,
    }
end

example :
    {* λ (t : thread_state (ℕ × ℕ) τ), t.tlocal.1 = 0 ∧ t.tlocal.1 = 0 *} kernel.compute (λ l, (l.1, 1)) {* λ (t : thread_state (ℕ × ℕ) τ), t.tlocal.2 = 1 *} →
    {* λ (t : thread_state (ℕ × ℕ) τ), t.tlocal.1 = 0 ∧ ¬t.tlocal.1 = 0 *} kernel.compute (λ l, (l.1, 2)) {* λ (t : thread_state (ℕ × ℕ) τ), t.tlocal.2 = 1 *} →
    {* λ (t : thread_state (ℕ × ℕ) τ), t.tlocal.1 = 0 *} kernel.ite (λt, t.1 = 0) (kernel.compute (λ l, (l.1, 1))) (kernel.compute (λ l, (l.1, 2))) {* λ (t : thread_state (ℕ × ℕ) τ), t.tlocal.2 = 1 *} := begin
    intros h_then h_else n s u ac hp he i hac,
    cases he,
    sorry,
end

end parlang


import condensed.top_comparison

open category_theory

namespace Condensed

universes u
variables {X Y : Condensed.{u} Ab.{u+1}} (f : X ⟶ Y)

lemma is_iso_iff_ExtrDisc :
  is_iso f ↔ (∀ S : ExtrDisc, is_iso (f.val.app (opposite.op S.val))) :=
begin
  split,
  { introsI h S,
    change is_iso ((Condensed.evaluation _ _).map f),
    apply_instance },
  { introsI h,
    suffices : is_iso ((Condensed_ExtrSheafProd_equiv Ab).functor.map f),
    { resetI,
      apply is_iso_of_fully_faithful (Condensed_ExtrSheafProd_equiv Ab.{u+1}).functor f },
    suffices : is_iso (((ExtrSheafProd_to_presheaf Ab.{u+1})).map
      ((Condensed_ExtrSheafProd_equiv Ab.{u+1}).functor.map f)),
    { resetI,
      apply is_iso_of_fully_faithful (ExtrSheafProd_to_presheaf Ab.{u+1}) },
    apply_with nat_iso.is_iso_of_is_iso_app { instances := ff },
    intros S, apply h }
end

end Condensed


import for_mathlib.algebraic_topology.homotopical_algebra.bifibrant_object
import for_mathlib.category_theory.localization.equivalence

noncomputable theory

open category_theory category_theory.limits category_theory.category category_theory

namespace algebraic_topology

namespace model_category

variables {C : Type*} [category C] [model_category C]

namespace bifibrant_replacement

def obj (X : cofibrant_object C) : bifibrant_object C :=
bifibrant_object.mk (CM5a.obj (terminal.from X.obj))

def app (X : cofibrant_object C) : X ⟶ cofibrant_object.mk (obj X).obj :=
CM5a.i (terminal.from X.obj)

instance (X : cofibrant_object C) : cofibration ((cofibrant_object.forget C).map (app X)) :=
by { dsimp [app], apply_instance, }
instance weak_eq_forget_map_app (X : cofibrant_object C) : weak_eq ((cofibrant_object.forget C).map (app X)) :=
by { dsimp [app], apply_instance, }

def app' (X : bifibrant_object C) : X ⟶ obj (cofibrant_object.mk X.obj) :=
app (cofibrant_object.mk X.obj)

def map' {X Y : cofibrant_object C} (f : X ⟶ Y) : obj X ⟶ obj Y :=
begin
  have sq : comm_sq ((cofibrant_object.forget C).map (f ≫ app Y))
    ((cofibrant_object.forget C).map (app X))
      (terminal.from (obj Y).obj) (terminal.from (obj X).obj) := by tidy,
  exact sq.lift,
end

instance (X : bifibrant_object C) : weak_eq ((bifibrant_object.forget C).map (app' X)) :=
begin
  change weak_eq ((cofibrant_object.forget C).map (app ((bifibrant_object.forget_fib C).obj X))),
  apply_instance,
end

@[reassoc]
lemma fac {X Y : cofibrant_object C} (f : X ⟶ Y) :
  app X ≫ (bifibrant_object.forget_fib C).map (map' f) = f ≫ app Y :=
by apply comm_sq.fac_left

lemma fac' {X Y : bifibrant_object C} (f : X ⟶ Y) :
  app' X ≫ map' ((bifibrant_object.forget_fib C).map f) = f ≫ app' Y :=
by apply fac

def map {X Y : cofibrant_object C} (f : X ⟶ Y) :
  bifibrant_object.homotopy_category.Q.obj (obj X) ⟶
  bifibrant_object.homotopy_category.Q.obj (obj Y) :=
bifibrant_object.homotopy_category.Q.map (map' f)

lemma map_eq {X Y : cofibrant_object C} (f : X ⟶ Y) (f' : obj X ⟶ obj Y)
  (sq : comm_sq (app X) f ((bifibrant_object.forget_fib C).map f') (app Y)) :
  map f = bifibrant_object.homotopy_category.Q.map f' :=
begin
  dsimp only [map],
  let P := path_object.some (obj Y).obj,
  rw bifibrant_object.homotopy_category.Q_map_eq_iff' P,
  have sq : comm_sq ((cofibrant_object.forget C).map (f ≫ app Y) ≫ P.σ)
    ((cofibrant_object.forget C).map (app X)) P.π
    (prod.lift ((bifibrant_object.forget C).map (map' f))
      ((bifibrant_object.forget C).map f')),
  { refine comm_sq.mk _,
    ext,
    { simpa only [pre_path_object.π, cofibrant_object.forget_map, assoc, pre_path_object.d₀σ,
        comp_id, prod.lift_fst, bifibrant_object.forget_map] using (fac f).symm, },
    { simpa only [pre_path_object.π, cofibrant_object.forget_map, assoc, comp_id,
        pre_path_object.d₁σ, prod.lift_snd, bifibrant_object.forget_map] using sq.w.symm, }, },
  exact nonempty.intro
  { h := sq.lift,
    h₀' := by simpa using congr_arg (λ f, f ≫ limits.prod.fst) sq.fac_right,
    h₁' := by simpa using congr_arg (λ f, f ≫ limits.prod.snd) sq.fac_right, },
end

end bifibrant_replacement

variable (C)

@[simps]
def bifibrant_replacement : cofibrant_object C ⥤ bifibrant_object.homotopy_category C :=
{ obj := λ X, bifibrant_object.homotopy_category.Q.obj (bifibrant_replacement.obj X),
  map := λ X Y f, bifibrant_replacement.map f,
  map_id' := λ X, begin
    rw [bifibrant_replacement.map_eq _ (𝟙 _), bifibrant_object.homotopy_category.Q.map_id],
    exact comm_sq.mk (by { simpa only [bifibrant_object.forget_fib_map, id_comp] using comp_id _,})
  end,
  map_comp' := λ X Y Z f g, begin
    rw [bifibrant_replacement.map_eq (f ≫ g)
      (bifibrant_replacement.map' f ≫ bifibrant_replacement.map' g), functor.map_comp],
    { refl, },
    { refine comm_sq.mk _,
      rw [functor.map_comp, assoc, bifibrant_replacement.fac_assoc f,
        bifibrant_replacement.fac g], },
  end, }

variables {C} {Hocof : Type*} [category Hocof] (Lcof : cofibrant_object C ⥤ Hocof)
  [Lcof.is_localization cofibrant_object.weq]
  {Hobif : Type*} [category Hobif] (Lbif : bifibrant_object C ⥤ Hobif)
  [Lbif.is_localization bifibrant_object.weq]

namespace bifibrant_replacement

@[simps]
def π : bifibrant_object.homotopy_category C ⥤ Hobif :=
bifibrant_object.homotopy_category.lift Lbif (localization.inverts Lbif bifibrant_object.weq)

lemma forget_comp_Lcof_inverts_weq :
  bifibrant_object.weq.is_inverted_by (bifibrant_object.forget_fib C ⋙ Lcof) :=
λ X Y f hf, by convert localization.inverts Lcof cofibrant_object.weq f hf

def R : cofibrant_object C ⥤ Hobif := bifibrant_replacement C ⋙ π Lbif

lemma R_inverts_weq : cofibrant_object.weq.is_inverted_by (R Lbif) := λ X Y f hf,
begin
  dsimp only [R, functor.comp_map],
  haveI : is_iso ((bifibrant_replacement C).map f),
  { dsimp only [bifibrant_replacement],
    apply bifibrant_object.homotopy_category.Q_inverts_weq,
    change model_category.weq ((bifibrant_object.forget C).map (map' f)),
    have h : weq ((cofibrant_object.forget C).map f ≫ (cofibrant_object.forget C).map (app Y)) :=
      CM2.of_comp _ _ hf weak_eq.property,
    have eq := (cofibrant_object.forget C).congr_map (fac f),
    simp only [functor.map_comp] at eq,
    rw ← eq at h,
    exact CM2.of_comp_left _ _ weak_eq.property h, },
  apply_instance,
end

def forget_comp_R_iso : bifibrant_object.forget_fib C ⋙ R Lbif ≅ Lbif :=
begin
  symmetry,
  exact nat_iso.of_components
    (λ X, localization.iso_of_hom' Lbif bifibrant_object.weq (app' X) weak_eq.property)
    (λ X Y f, by { rw [localization.iso_of_hom'_hom, ← Lbif.map_comp, ← fac', Lbif.map_comp], refl, }),
end

def R_comp_I'_iso {I' : Hobif ⥤ Hocof} (sq : Comm_sq (bifibrant_object.forget_fib C) Lbif Lcof I') :
  R Lbif ⋙ I' ≅ Lcof :=
begin
  symmetry,
  exact nat_iso.of_components (λ X, localization.iso_of_hom' Lcof cofibrant_object.weq
    (app X) weak_eq.property ≪≫ sq.iso.symm.app _) (λ X Y f, begin
    simp only [iso.trans_hom, localization.iso_of_hom'_hom, iso.app_hom, iso.symm_hom,
      functor.comp_map, assoc, ← Lcof.map_comp_assoc],
    simp only [← fac, functor.map_comp, assoc],
    congr' 1,
    apply sq.iso.inv.naturality,
  end),
end

def is_equivalence (I' : Hobif ⥤ Hocof)
  (sq : Comm_sq (bifibrant_object.forget_fib C) Lbif Lcof I') : is_equivalence I' :=
localization.lifting_is_equivalence sq bifibrant_object.weq cofibrant_object.weq
  (R Lbif) (localization.lift (R Lbif) (R_inverts_weq Lbif) Lcof)
  (R_comp_I'_iso Lcof Lbif sq) (forget_comp_R_iso Lbif)

end bifibrant_replacement

def Hobif_to_Hocof : Hobif ⥤ Hocof :=
localization.lift ((bifibrant_object.forget_fib C) ⋙ Lcof)
  (bifibrant_replacement.forget_comp_Lcof_inverts_weq Lcof) Lbif

def Lbif_comp_Hobif_to_Hocof_iso : Lbif ⋙ Hobif_to_Hocof Lcof Lbif ≅
  bifibrant_object.forget_fib C ⋙ Lcof := localization.fac _ _ _

instance : is_equivalence (Hobif_to_Hocof Lcof Lbif) :=
bifibrant_replacement.is_equivalence Lcof Lbif (Hobif_to_Hocof Lcof Lbif)
  ⟨Lbif_comp_Hobif_to_Hocof_iso Lcof Lbif⟩

instance : full (bifibrant_object.forget_fib C ⋙ Lcof) :=
full.of_iso (Lbif_comp_Hobif_to_Hocof_iso Lcof bifibrant_object.homotopy_category.Q)

end model_category

end algebraic_topology


import tactic.induction
import data.int.basic
import data.set.basic
import logic.function.iterate

import .defs .game .played_move

noncomputable theory
open_locale classical

lemma not_A_hws_at_of {pw : ℕ} {s : State}
  (h : D_hws_at pw s) : ¬A_hws_at pw s :=
begin
  cases h with d h, change ¬∃ _, _, push_neg,
  intro a, use d, rw not_A_wins_at, apply h,
end

lemma not_D_hws_at_of {pw : ℕ} {s : State}
  (h : A_hws_at pw s) : ¬D_hws_at pw s :=
begin
  cases h with d h, change ¬∃ _, _, push_neg,
  intro a, use d, rw not_D_wins_at, apply h,
end

-----

lemma act_of_not_D_hws {pw : ℕ} {s : State}
  (h : ¬D_hws_at pw s) : s.act :=
by { contrapose! h, use default, intro a, use 0 }

lemma A_hvm_of_not_D_hws {pw : ℕ} {s : State}
  (h : ¬D_hws_at pw s) :
  ∀ (md : Valid_D_move s.board),
  A_has_valid_move pw (apply_D_move s md.m).board :=
begin
  intro md, rw D_hws_at at h, push_neg at h,
  let d := (default : D).set_move s md, specialize h d,
  cases h with a h, rw not_D_wins_at at h, specialize h 1, rw play_1 at h,
  rw Game.play_move at h, split_ifs at h with h₁, swap, { contradiction },
  rw play_A_move_at at h, split_ifs at h with h₂, swap, { cases h },
  cases h₂ with h₂ h₃, convert h₃, change _ = dite _ _ _, rw dif_pos; refl,
end

lemma exi_moves_hws_of_not_D_hws {pw : ℕ} {s : State}
  (h : ¬D_hws_at pw s) :
  ∀ (md : Valid_D_move s.board) (d : D),
  ∃ (ma : Valid_A_move pw (apply_D_move s md.m).board) (a : A pw),
  (init_game a d (apply_A_move (apply_D_move s md.m) ma.m)).A_wins :=
begin
  have hs : s.act := act_of_not_D_hws h,
  have h₁ : ¬∃ _, _ := h, push_neg at h₁,
  simp_rw not_D_wins_at at h₁, rintro md d₀, let md₀ := d₀.f s hs,
  let d := d₀.set_move s md, let s' := apply_D_move s md.m,
  change apply_D_move s md.m with s',
  have h₂ : A_has_valid_move pw s'.board,
  { apply A_hvm_of_not_D_hws h },
  specialize h₁ d, cases h₁ with a h₁, let ma := a.f s' hs h₂, use [ma, a],
  have hh : d₀ = d.set_move s md₀,
  { change d₀ = (d₀.set_move s md).set_move s md₀,
    rw [D_set_move_set_move_eq, D_set_move_self] },
  rw hh, have h₃ : (init_game a d (apply_A_move s' ma.m)).A_wins,
  { convert A_wins_at_play_move_of h₁,
    rw init_game_play_move hs, change _ = dite _ _ _,
    have h₃ : (play_D_move_at (init_game a d s) hs).s = s',
    { change apply_D_move s _ = apply_D_move s _,
      congr, change dite _ _ _ = md, change (init_game a d s).s with s,
      rw dif_pos rfl },
    simp_rw h₃, rw dif_pos, swap, { split; assumption },
    ext; try {refl}, rw play_A_move_at', dsimp,

    sorry
    -- simp_rw h₃, change (play_D_move_at (init_game a d s) hs).a with a,
    -- generalize_proofs h₄, convert_to _ = apply_A_move s' (a.f s' hs h₂).m,
    -- { congr; try {exact h₃}, convert_to trivial == trivial,
    --   { exact eq_true_intro h₄ }, { exact eq_true_intro h₂ }, refl
  },
  let g : Game pw := _, change g.A_wins at h₃,
  let g₁ : Game pw := _, change g₁.A_wins,
  have h₄ : g₁ = g.set_D (d.set_move s md₀) := rfl, rw h₄, clear h₄,
  have h₄ : s.len < (g.set_D d).s.len,
  { exact length_lt_length_snoc₂ },
  apply (D_set_move_A_wins_iff h₄).mpr, exact h₃,
end

def mk_D_st_for_ma_exi_D_st {pw : ℕ} {s' : State}
  (h : ∀ (ma : Valid_A_move pw s'.board),
    ∃ (d : D), ∀ (a : A pw),
    (init_game a d (apply_A_move s' ma.m)).D_wins) :
  D :=
begin
  refine ⟨λ sx, _⟩,
  apply dite (∃ (ma : Valid_A_move pw s'.board),
    A_played_move_at sx s' ma); rintro h₁,
  { exact (h h₁.some).some.f sx },
  { exact default },
end

-- Lemma 3.1.1
-- Ross Bryant - Borel determinacy and metamathematics
-- Master's thesis, University of North Texas, 2001
lemma exi_A_move_hws_of_not_D_hws {pw : ℕ} {s : State}
  (h : ¬D_hws_at pw s) :
  ∀ (md : Valid_D_move s.board),
  ∃ (ma : Valid_A_move pw (apply_D_move s md.m).board),
  ¬D_hws_at pw (apply_A_move (apply_D_move s md.m) ma.m) :=
begin
  have hs := act_of_not_D_hws h,
  have h₁ := exi_moves_hws_of_not_D_hws h,
  intro md, specialize h₁ md, simp_rw D_hws_at, contrapose! h₁,
  simp_rw not_A_wins_at at h₁ ⊢,
  let D := mk_D_st_for_ma_exi_D_st h₁, use D,
  rintro ma a, have h₂ := h₁ ma, let s' := apply_D_move s md.m,
  change apply_D_move s md.m with s' at ma h₁ h₂ ⊢,
  let s₁ := apply_A_move s' ma.m,
  change apply_A_move s' ma.m with s₁ at h₁ h₂ ⊢,
  let d := h₂.some, have h₃ := h₂.some_spec,
  change ∀ (a : A pw), (init_game a d s₁).D_wins at h₃,
  specialize h₃ a, contrapose! h₃, rw not_D_wins_at at h₃ ⊢,
  intro n, specialize h₃ n, suffices h₄ : (init_game a D s₁).play n =
    ((init_game a d s₁).play n).set_D D, { rwa h₄ at h₃ }, clear h₃,
  induction n with n ih, { refl }, simp_rw [play_at_succ', ih], clear ih,
  let g : Game pw := _, change (init_game a d s₁).play n with g,
  simp_rw Game.play_move, change (g.set_D D).act with g.act,
  split_ifs with h₃, swap, { refl }, have h₅ : g.d = d := play_at_players_eq.2,
  simp_rw play_D_move_at, change (g.set_D D).s with g.s,
  change (g.set_D D).d with D, rw h₅,
  suffices h₆ : apply_D_move g.s (D.f g.s h₃).m =
    apply_D_move g.s (d.f g.s h₃).m,
  { rw [h₆, ←play_A_move_at_set_D], refl },
  simp_rw apply_D_move, congr' 3,
  have h₆ : ∃ (ma : Valid_A_move pw s'.board),
    A_played_move_at g.s s' ma,
  { exact ⟨_, A_played_move_at_play
    (A_played_move_at_apply_move hs rfl)⟩ },
  change (mk_D_st_for_ma_exi_D_st _).f _ _ = _,
  rw mk_D_st_for_ma_exi_D_st, dsimp,
  split_ifs with hx, swap, { contradiction }, clear hx,
  generalize_proofs h₇, change apply_D_move s md.m with s' at h₇,
  have h₈ := h₇.some_spec, change d with h₂.some, congr,
  suffices h₉ : apply_A_move (apply_D_move s md.m) h₆.some.m = s₁,
  { rw h₉ }, change apply_A_move s' _ = apply_A_move _ _, congr,
  apply A_played_move_at_eq h₆.some_spec,
  exact A_played_move_at_play (A_played_move_at_apply_move hs rfl),
end

def mk_A_st_for_not_D_hws (pw : ℕ) : A pw :=
begin
  refine ⟨λ s' h, _⟩,
  apply dite (∃ (s : State) (md : Valid_D_move s.board),
    ¬D_hws_at pw s ∧ s' = apply_D_move s md.m); rintro h₁ h₂,
  { refine (_ : ∃ (ma : Valid_A_move pw s'.board),
      ¬D_hws_at pw (apply_A_move s' ma.m)).some,
    rcases h₁ with ⟨s, md, h₁, rfl⟩,
    use (exi_A_move_hws_of_not_D_hws h₁ _).some,
    generalize_proofs h₂, exact h₂.some_spec },
  { exact ⟨_, h₂.some_spec⟩ },
end

lemma not_D_hws_at_play_of_not_D_hws {pw n : ℕ} {g : Game pw}
  (h₁ : g.a = mk_A_st_for_not_D_hws pw)
  (h₂ : ¬D_hws_at pw g.s) :
  ¬D_hws_at pw (g.play n).s :=
begin
  rename g g₀, induction n with n ih, { exact h₂ }, clear h₂,
  rw play_at_succ', let g : Game pw := _,
  change ¬D_hws_at pw g.s at ih,
  change ¬D_hws_at pw g.play_move.s,
  change g.play_move with dite _ _ _,
  split_ifs, swap, { exact ih },
  let d := g.d, let s := g.s, let md := d.f s h,
  let s' := apply_D_move s md.m,
  have h₃ : ∃ (ma : Valid_A_move pw s'.board),
    ¬D_hws_at pw (apply_A_move s' ma.m),
  { exact exi_A_move_hws_of_not_D_hws ih md },
  have ma := h₃.some, have h₄ := h₃.some_spec,
  convert h₄, change Game.s (dite _ _ _) = _,
  have h₅ : A_has_valid_move pw s'.board := ⟨_, ma.h⟩,
  change (play_D_move_at g h).s with s',
  rw dif_pos, swap, { split; assumption },
  change apply_A_move _ _ = _, congr,
  change g.a.f s' h h₅ = _, let A : A pw := _, change g₀.a = A at h₁,
  have h₆ : g.a = A := by { rw ←h₁, exact play_at_players_eq.1 },
  rw h₆, change (mk_A_st_for_not_D_hws pw).f _ _ _ = _,
  rw mk_A_st_for_not_D_hws, dsimp, rw dif_pos, exact ⟨s, md, ih, rfl⟩,
end

lemma A_hws_at_of {pw : ℕ} {s : State}
  (h : ¬D_hws_at pw s) : A_hws_at pw s :=
begin
  have hs : s.act := act_of_not_D_hws h,
  let A := mk_A_st_for_not_D_hws pw, use A, rintro d n,
  induction n with n ih, { exact hs }, rw play_at_succ',
  let g : Game pw := _, change g.act at ih, change g.play_move.act,
  let s := g.s, let md := d.f s ih, let s' := apply_D_move s md.m,
  rw play_move_at_act ih, have h₁ : play_D_move_at g ih = g.set_state s',
  { convert play_D_move_eq, change apply_D_move _ (d.f s ih).m = _,
    congr, symmetry, exact play_at_players_eq.2 },
  rw h₁, clear h₁, have h₁ : A_has_valid_move pw s'.board,
  { have h₁ : ¬D_hws_at pw s := not_D_hws_at_play_of_not_D_hws rfl h,
    exact ⟨_, (exi_A_move_hws_of_not_D_hws h₁ md).some.h⟩ },
  change Game.act (dite _ _ _), change (g.set_state s').s with s',
  rw dif_pos, swap, { split; assumption }, exact ih,
end

-----

lemma D_hws_at_of {pw : ℕ} {s : State}
  (h : ¬A_hws_at pw s) : D_hws_at pw s :=
by { contrapose! h, exact A_hws_at_of h }

lemma not_A_hws_at_iff {pw : ℕ} {s : State} :
  ¬A_hws_at pw s ↔ D_hws_at pw s :=
⟨D_hws_at_of, not_A_hws_at_of⟩

lemma not_D_hws_at_iff {pw : ℕ} {s : State} :
  ¬D_hws_at pw s ↔ A_hws_at pw s :=
⟨A_hws_at_of, not_D_hws_at_of⟩


import category_theory.adjunction.basic
import category_theory.limits.has_limits
import category_theory.limits.preserves.basic

noncomputable theory

namespace category_theory

open category

lemma adjunction.compatibility {C D : Type*} [category C] [category D]
  {G : C ⥤ D} {F : D ⥤ C} (adj : G ⊣ F) {X : C} {Y : D}
  (f : G.obj X ⟶ Y) : G.map (adj.unit.app X) ≫ (F ⋙ G).map f ≫ adj.counit.app Y = f :=
by simp only [functor.comp_map, adjunction.counit_naturality, adjunction.left_triangle_components_assoc]

section

variables {C₁ C₂ D₁ D₂ : Type*} [category C₁] [category C₂]
  [category D₁] [category D₂] {G₁ : C₁ ⥤ D₁} {F₁ : D₁ ⥤ C₁}
  {G₂ : C₂ ⥤ D₂} {F₂ : D₂ ⥤ C₂}
  (adj₁ : G₁ ⊣ F₁) (adj₂ : G₂ ⊣ F₂)
  {L : C₁ ⥤ C₂} {L' : D₁ ⥤ D₂}

include adj₁ adj₂

def adjunction.adjoint_nat_trans_equiv :
  (L ⋙ G₂ ⟶ G₁ ⋙ L') ≃ (F₁ ⋙ L ⟶ L' ⋙ F₂) :=
{ to_fun := λ τ, begin
    let α := 𝟙 (F₁ ⋙ L) ◫ adj₂.unit,
    let β := (𝟙 F₁) ◫ τ ◫ (𝟙 F₂),
    let γ := adj₁.counit ◫ 𝟙 (L' ⋙ F₂),
    exact α ≫ β ≫ γ,
  end,
  inv_fun := λ τ', begin
    let α := adj₁.unit ◫ (𝟙 (L ⋙ G₂)),
    let β := (𝟙 G₁) ◫ τ' ◫ (𝟙 G₂),
    let γ := 𝟙 (G₁ ⋙ L') ◫ adj₂.counit,
    exact α ≫ β ≫ γ,
  end,
  left_inv := λ τ, begin
    ext X,
    dsimp,
    simp only [id_comp, functor.map_id, comp_id, assoc, functor.map_comp,
      adjunction.counit_naturality, adjunction.counit_naturality_assoc,
      adjunction.left_triangle_components_assoc],
    erw τ.naturality_assoc,
    dsimp,
    rw [← L'.map_comp, adj₁.left_triangle_components, L'.map_id,
      comp_id],
  end,
  right_inv := λ τ', begin
    ext Y,
    dsimp,
    simp only [functor.map_id, id_comp, assoc, functor.map_comp,
      adjunction.unit_naturality_assoc, adjunction.right_triangle_components_assoc],
    erw ← τ'.naturality,
    dsimp,
    rw [← L.map_comp_assoc, adj₁.right_triangle_components, L.map_id, id_comp],
  end, }

@[simp]
lemma adjunction.adjoint_nat_trans_equiv_app (τ : L ⋙ G₂ ⟶ G₁ ⋙ L') (Y₁ : D₁) :
  (adjunction.adjoint_nat_trans_equiv adj₁ adj₂ τ).app Y₁ =
    adj₂.unit.app (L.obj (F₁.obj Y₁)) ≫
      F₂.map (τ.app (F₁.obj Y₁)) ≫
      F₂.map (L'.map (adj₁.counit.app Y₁)) :=
begin
  dsimp [adjunction.adjoint_nat_trans_equiv],
  simp only [functor.map_id, comp_id, id_comp],
end

@[simp]
lemma adjunction.adjoint_nat_trans_equiv_symm_app (τ : F₁ ⋙ L ⟶ L' ⋙ F₂) (X₁ : C₁) :
  ((adjunction.adjoint_nat_trans_equiv adj₁ adj₂).symm τ).app X₁ =
  G₂.map (L.map (adj₁.unit.app X₁)) ≫
      G₂.map (τ.app (G₁.obj X₁)) ≫ adj₂.counit.app (L'.obj (G₁.obj X₁)) :=
begin
  dsimp [adjunction.adjoint_nat_trans_equiv],
  simp only [id_comp, functor.map_id, comp_id],
end

end

def functor.comp_const {C D : Type*} [category C] [category D]
  (F : C ⥤ D) (J : Type*) [category J] :
  F ⋙ (functor.const J) ≅ (functor.const J) ⋙ (whiskering_right J C D).obj F :=
nat_iso.of_components (λ X, nat_iso.of_components (λ j, iso.refl _) (by tidy)) (by tidy)

namespace limits

section

variables {J : Type*} {C : Type*} [category J] [category C]
  {F : (J ⥤ C) ⥤ C} (adj : functor.const J ⊣ F)

include adj

lemma is_limit_of_is_iso_adj {X : J ⥤ C} (c : cone X)
  (h : is_iso ((adj.hom_equiv _ _) c.π)) : is_limit c :=
begin
  haveI := h,
  exact
  { lift := λ s, (adj.hom_equiv _ _) s.π ≫ inv ((adj.hom_equiv _ _) c.π),
    fac' := λ s, begin
      suffices : (functor.const J).map ((adj.hom_equiv s.X X) s.π ≫ inv ((adj.hom_equiv c.X X) c.π)) ≫ c.π = s.π,
      { exact nat_trans.congr_app this, },
      apply (adj.hom_equiv _ _).injective,
      rw [adjunction.hom_equiv_naturality_left, assoc, is_iso.inv_hom_id, comp_id],
    end,
    uniq' := λ s m hm, begin
      rw [← cancel_mono ((adj.hom_equiv c.X X) c.π), assoc, is_iso.inv_hom_id, comp_id],
      apply (adj.hom_equiv _ _).symm.injective,
      simp only [adjunction.hom_equiv_naturality_left_symm, equiv.symm_apply_apply],
      ext j,
      exact hm j,
    end, },
end

lemma is_iso_adj_of_is_limit {X : J ⥤ C} {c : cone X} (hc : is_limit c) :
  is_iso ((adj.hom_equiv _ _) c.π) :=
begin
  refine is_iso.mk ⟨hc.lift (cone.mk (F.obj X) (adj.counit.app X)), _, _⟩,
  { apply hc.hom_ext,
    intro j,
    simpa only [adjunction.hom_equiv_unit, assoc, is_limit.fac, id_comp]
      using nat_trans.congr_app (adj.compatibility c.π) j, },
  { apply (adj.hom_equiv _ _).symm.injective,
    rw [adjunction.hom_equiv_naturality_left_symm, equiv.symm_apply_apply,
      adjunction.hom_equiv_counit, functor.map_id],
    ext j,
    rw id_comp,
    apply hc.fac, },
end

@[simps]
def limit_cone_of_adj (X : J ⥤ C) : limit_cone X :=
⟨cone.mk (F.obj X) (adj.counit.app X), is_limit_of_is_iso_adj adj _ (by tidy)⟩

lemma has_limits_of_shape_of_adj : has_limits_of_shape J C :=
⟨λ X, ⟨nonempty.intro (limit_cone_of_adj adj X)⟩⟩

end

section

variables {C₁ C₂ J : Type*} [category C₁] [category C₂] [category J]
  {F₁ : (J ⥤ C₁) ⥤ C₁} {F₂ : (J ⥤ C₂) ⥤ C₂} (adj₁ : functor.const J ⊣ F₁)
  (adj₂ : functor.const J ⊣ F₂) (L : C₁ ⥤ C₂)

include adj₁ adj₂

@[simp]
def limit_comparison_of_adj : F₁ ⋙ L ⟶ (whiskering_right J _ _).obj L ⋙ F₂ :=
(adjunction.adjoint_nat_trans_equiv adj₁ adj₂)(L.comp_const J).hom

lemma preserves_limit_of_adj (X : J ⥤ C₁)
  (hX : is_iso ((limit_comparison_of_adj adj₁ adj₂ L).app X)) : preserves_limit X L :=
begin
  refine preserves_limit_of_preserves_limit_cone (limit_cone_of_adj adj₁ X).is_limit _,
  refine is_limit_of_is_iso_adj adj₂ _ _,
  convert hX,
  apply (adj₂.hom_equiv _ _).symm.injective,
  ext j,
  dsimp [limit_cone_of_adj, functor.map_cone],
  rw [equiv.symm_apply_apply, cones.functoriality_obj_π_app,
    adjunction.adjoint_nat_trans_equiv_app, whiskering_right_obj_map, ← assoc,
    adjunction.hom_equiv_naturality_right_symm, nat_trans.comp_app, whisker_right_app,
    adjunction.hom_equiv_naturality_right_symm, adjunction.hom_equiv_counit,
    adjunction.left_triangle_components],
  dsimp [functor.comp_const],
  simp only [id_comp],
end

lemma preserves_limits_of_shape_of_adj
  [is_iso (limit_comparison_of_adj adj₁ adj₂ L)] : preserves_limits_of_shape J L :=
⟨λ X, preserves_limit_of_adj adj₁ adj₂ L X infer_instance⟩

end

end limits

end category_theory


import for_mathlib.exact_functor
import for_mathlib.ab4
import for_mathlib.abelian_sheaves.functor_category
import for_mathlib.homological_complex2
import category_theory.limits.preserves.filtered
import for_mathlib.short_complex_colimits

namespace category_theory

open category_theory.limits

universes v u
variables (A : Type u) [category.{v} A] [abelian A] [has_colimits A]

instance colim_additive (J : Type v) [small_category J]:
  functor.additive (limits.colim : ((J ⥤ A) ⥤ A)) := ⟨⟩ .

/-
TODO: Change `AB5` from this definition to saying that `colim : (J ⥤ A) ⥤ A`
preserves finite limits and colimits whenever `J` is filtered.
-/
class AB5 : Prop :=
(cond [] : ∀ (J : Type v) [small_category J] [is_filtered J],
  functor.exact (limits.colim : (J ⥤ A) ⥤ A))

variables (J : Type v) [small_category J] [is_filtered J]

lemma AB5.colim_exact [AB5 A] :
  functor.exact (limits.colim : (J ⥤ A) ⥤ A) :=
AB5.cond A J

variables
  [preserves_finite_limits (limits.colim : (J ⥤ A) ⥤ A)]
  [preserves_finite_colimits (limits.colim : (J ⥤ A) ⥤ A)]

noncomputable
def colimit_homology_functor_iso
  {M : Type} (c : complex_shape M) (i : M) :
  homology_functor (J ⥤ A) c i ⋙ limits.colim ≅
  (limits.colim.map_homological_complex _) ⋙ homology_functor _ _ i :=
functor.homology_functor_iso _ _ _

noncomputable
def eval_functor_colimit_iso
  {M : Type} (c : complex_shape M)
  (F : J ⥤ homological_complex A c) :
  colimit F ≅ (limits.colim.map_homological_complex c).obj
  (homological_complex.eval_functor.obj F) :=
homological_complex.hom.iso_of_components
(λ i, preserves_colimit_iso (homological_complex.eval A c i) _)
begin
  intros i j hij,
  rw ←iso.eq_inv_comp,
  apply colimit.hom_ext,
  intro k,
  dsimp,
  simp only [colimit.ι_map, whisker_left_app, ι_preserves_colimits_iso_inv_assoc,
    homological_complex.eval_map, homological_complex.hom.comm_assoc],
  congr,
  rw [preserves_colimit_iso, ← limits.colimit.iso_colimit_cocone_ι_inv
    ⟨_, preserves_colimit.preserves (colimit.is_colimit F)⟩],
  refl
end

noncomputable
instance homology_functor_preserves_filtered_colimit
  {M : Type} (c : complex_shape M) (i : M)
  (F : J ⥤ homological_complex A c) :
  preserves_colimit F (homology_functor A c i) :=
preserves_colimit_of_nat_iso F (short_complex.homology_functor_iso A c i).symm

noncomputable
instance homology_functor_preserves_filtered_colimits
  {M : Type} (c : complex_shape M) (i : M)
  [∀ (J : Type v) [hJ : small_category J]
    [@is_filtered J hJ],
    by exactI preserves_finite_limits (limits.colim : (J ⥤ A) ⥤ A)]
  [∀ (J : Type v) [hJ : small_category J]
    [@is_filtered J hJ],
    by exactI preserves_finite_colimits (limits.colim : (J ⥤ A) ⥤ A)] :
  preserves_filtered_colimits
  (homology_functor A c i : homological_complex A c ⥤ A) :=
begin
  constructor, introsI J _ _, constructor,
end

end category_theory