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

/-!
# Unbundled algebra classes

These classes are part of an incomplete refactor described
[here on the github Wiki](https://github.com/leanprover/lean/wiki/Refactoring-structures#encoding-the-algebraic-hierarchy-1).
However a subset of them are widely used in mathlib3,
and it has been tricky to clean this up as this file was in core Lean 3.

By themselves, these classes are not good replacements for the `monoid` / `group` etc structures
provided by mathlib, as they are not discoverable by `simp` unlike the current lemmas due to there
being little to index on.

## Porting notes:
This file is ancient, and it would be good to replace it with a clean version
that provides what mathlib4 actually needs.

I've omitted all the `@[algebra]` attributes, as they are not used elsewhere.

The section `StrictWeakOrder` has been omitted, but I've left the mathport output in place.
Please delete if cleaning up.

I've commented out some classes which we think are completely unused in mathlib.

I've added many of the declarations to `nolints.json`.
If you clean up this file, please add documentation to classes that we are keeping.

Mario made the following analysis of uses in mathlib3:
* `is_symm_op`: unused except for some instances
* `is_commutative`: used a fair amount via some theorems about folds
  (also assuming `is_associative`)
* `is_associative`: ditto, also used in `noncomm_fold`
* `is_left_id`, `is_right_id`: unused except in the mathlib class `is_unital` and in `mono`
  (which looks like it could use `is_unital`)
* `is_left_null`, `is_right_null`: unused
* `is_left_cancel`, `is_right_cancel`: unused except for instances
* `is_idempotent`: this one is actually used to prove things not directly about `is_idempotent`
* `is_left_distrib`, `is_right_distrib`, `is_left_inv`, `is_right_inv`, `is_cond_left_inv`,
  `is_cond_right_inv`: unused
* `is_distinct`: unused (although we reinvented this one as `nontrivial`)
* `is_irrefl`, `is_refl`, `is_symm`, `is_trans`: significant usage
* `is_asymm`, `is_antisymm`, `is_total`, `is_strict_order`: a lot of uses but all in order theory
  and it's unclear how much could not be transferred to another typeclass
* `is_preorder`: unused except for instances
  (except `antisymmetrization`, maybe it could be transferred)
* `is_total_preorder`, `is_partial_order`: unused except for instances
* `is_linear_order`: unused except for instances
* `is_equiv`: unused except for instances (most uses can use `equivalence` instead)
* `is_per`: unused
* `is_incomp_trans`: unused
* `is_strict_weak_order`: significant usage (most of it on `rbmap`, could be transferred)
* `is_trichotomous`: some usage
* `is_strict_total_order`: looks like the only usage is in `rbmap` again
-/

universe u v

class IsSymmOp (α : Type u) (β : Type v) (op : α → α → β) : Prop where
  symm_op : ∀ a b, op a b = op b a

/-- A commutative binary operation. -/
class IsCommutative (α : Type u) (op : α → α → α) : Prop where
  comm : ∀ a b, op a b = op b a

instance [IsCommutative α op] : Lean.IsCommutative op where
  comm := IsCommutative.comm

instance isSymmOp_of_isCommutative (α : Type u) (op : α → α → α)
    [IsCommutative α op] : IsSymmOp α α op where symm_op :=
  IsCommutative.comm

/-- An associative binary operation. -/
class IsAssociative (α : Type u) (op : α → α → α) : Prop where
  assoc : ∀ a b c, op (op a b) c = op a (op b c)

instance [IsAssociative α op] : Lean.IsAssociative op where
  assoc := IsAssociative.assoc

/-- A binary operation with a left identity. -/
class IsLeftId (α : Type u) (op : α → α → α) (o : outParam α) : Prop where
  left_id : ∀ a, op o a = a

/-- A binary operation with a right identity. -/
class IsRightId (α : Type u) (op : α → α → α) (o : outParam α) : Prop where
  right_id : ∀ a, op a o = a

instance [IsLeftId α op o] [IsRightId α op o] : Lean.IsNeutral op o where
  left_neutral := IsLeftId.left_id
  right_neutral := IsRightId.right_id

-- -- class IsLeftNull (α : Type u) (op : α → α → α) (o : outParam α) : Prop where
--   left_null : ∀ a, op o a = o

-- -- class IsRightNull (α : Type u) (op : α → α → α) (o : outParam α) : Prop where
--   right_null : ∀ a, op a o = o

class IsLeftCancel (α : Type u) (op : α → α → α) : Prop where
  left_cancel : ∀ a b c, op a b = op a c → b = c

class IsRightCancel (α : Type u) (op : α → α → α) : Prop where
  right_cancel : ∀ a b c, op a b = op c b → a = c

class IsIdempotent (α : Type u) (op : α → α → α) : Prop where
  idempotent : ∀ a, op a a = a

instance [IsIdempotent α op] : Lean.IsIdempotent op where
  idempotent := IsIdempotent.idempotent

--class IsLeftDistrib (α : Type u) (op₁ : α → α → α) (op₂ : outParam <| α → α → α) : Prop where
--   left_distrib : ∀ a b c, op₁ a (op₂ b c) = op₂ (op₁ a b) (op₁ a c)

-- class IsRightDistrib (α : Type u) (op₁ : α → α → α) (op₂ : outParam <| α → α → α) : Prop where
--   right_distrib : ∀ a b c, op₁ (op₂ a b) c = op₂ (op₁ a c) (op₁ b c)

-- class IsLeftInv (α : Type u) (op : α → α → α) (inv : outParam <| α → α) (o : outParam α) :
--     Prop where
--   left_inv : ∀ a, op (inv a) a = o

-- class IsRightInv (α : Type u) (op : α → α → α) (inv : outParam <| α → α) (o : outParam α) :
--     Prop where
--   right_inv : ∀ a, op a (inv a) = o

-- class IsCondLeftInv (α : Type u) (op : α → α → α) (inv : outParam <| α → α) (o : outParam α)
--   (p : outParam <| α → Prop) : Prop where
--   left_inv : ∀ a, p a → op (inv a) a = o

-- class IsCondRightInv (α : Type u) (op : α → α → α) (inv : outParam <| α → α) (o : outParam α)
--   (p : outParam <| α → Prop) : Prop where
--   right_inv : ∀ a, p a → op a (inv a) = o

-- class IsDistinct (α : Type u) (a : α) (b : α) : Prop where
--   distinct : a ≠ b

/-
-- The following type class doesn't seem very useful, a regular simp lemma should work for this.
class is_inv (α : Type u) (β : Type v) (f : α → β) (g : out β → α) : Prop :=
(inv : ∀ a, g (f a) = a)

-- The following one can also be handled using a regular simp lemma
class is_idempotent (α : Type u) (f : α → α) : Prop :=
(idempotent : ∀ a, f (f a) = f a)
-/
/-- `IsIrrefl X r` means the binary relation `r` on `X` is irreflexive (that is, `r x x` never
holds). -/
class IsIrrefl (α : Type u) (r : α → α → Prop) : Prop where
  irrefl : ∀ a, ¬r a a

/-- `IsRefl X r` means the binary relation `r` on `X` is reflexive. -/
class IsRefl (α : Type u) (r : α → α → Prop) : Prop where
  refl : ∀ a, r a a

/-- `IsSymm X r` means the binary relation `r` on `X` is symmetric. -/
class IsSymm (α : Type u) (r : α → α → Prop) : Prop where
  symm : ∀ a b, r a b → r b a

/-- The opposite of a symmetric relation is symmetric. -/
instance isSymmOp_of_isSymm (α : Type u) (r : α → α → Prop) [IsSymm α r] :
    IsSymmOp α Prop r where
  symm_op := fun a b ↦ propext <| Iff.intro (IsSymm.symm a b) (IsSymm.symm b a)

/-- `IsAsymm X r` means that the binary relation `r` on `X` is asymmetric, that is,
`r a b → ¬ r b a`. -/
class IsAsymm (α : Type u) (r : α → α → Prop) : Prop where
  asymm : ∀ a b, r a b → ¬r b a

/-- `IsAntisymm X r` means the binary relation `r` on `X` is antisymmetric. -/
class IsAntisymm (α : Type u) (r : α → α → Prop) : Prop where
  antisymm : ∀ a b, r a b → r b a → a = b

/-- `IsTrans X r` means the binary relation `r` on `X` is transitive. -/
class IsTrans (α : Type u) (r : α → α → Prop) : Prop where
  trans : ∀ a b c, r a b → r b c → r a c

instance {α : Type u} {r : α → α → Prop} [IsTrans α r] : Trans r r r :=
  ⟨IsTrans.trans _ _ _⟩

instance {α : Type u} {r : α → α → Prop} [Trans r r r] : IsTrans α r :=
  ⟨fun _ _ _ => Trans.trans⟩

/-- `IsTotal X r` means that the binary relation `r` on `X` is total, that is, that for any
`x y : X` we have `r x y` or `r y x`.-/
class IsTotal (α : Type u) (r : α → α → Prop) : Prop where
  total : ∀ a b, r a b ∨ r b a

/-- `IsPreorder X r` means that the binary relation `r` on `X` is a pre-order, that is, reflexive
and transitive. -/
class IsPreorder (α : Type u) (r : α → α → Prop) extends IsRefl α r, IsTrans α r : Prop

/-- `IsTotalPreorder X r` means that the binary relation `r` on `X` is total and a preorder. -/
class IsTotalPreorder (α : Type u) (r : α → α → Prop) extends IsTrans α r, IsTotal α r : Prop

/-- Every total pre-order is a pre-order. -/
instance isTotalPreorder_isPreorder (α : Type u) (r : α → α → Prop) [s : IsTotalPreorder α r] :
    IsPreorder α r where
  trans := s.trans
  refl := fun a ↦ Or.elim (@IsTotal.total _ r _ a a) id id

/-- `IsPartialOrder X r` means that the binary relation `r` on `X` is a partial order, that is,
`IsPreorder X r` and `IsAntisymm X r`. -/
class IsPartialOrder (α : Type u) (r : α → α → Prop) extends IsPreorder α r, IsAntisymm α r : Prop

/-- `IsLinearOrder X r` means that the binary relation `r` on `X` is a linear order, that is,
`IsPartialOrder X r` and `IsTotal X r`. -/
class IsLinearOrder (α : Type u) (r : α → α → Prop) extends IsPartialOrder α r, IsTotal α r : Prop

/-- `IsEquiv X r` means that the binary relation `r` on `X` is an equivalence relation, that
is, `IsPreorder X r` and `IsSymm X r`. -/
class IsEquiv (α : Type u) (r : α → α → Prop) extends IsPreorder α r, IsSymm α r : Prop

-- /-- `IsPer X r` means that the binary relation `r` on `X` is a partial equivalence relation, that
-- is, `IsSymm X r` and `IsTrans X r`. -/
-- -- class IsPer (α : Type u) (r : α → α → Prop) extends IsSymm α r, IsTrans α r : Prop

/-- `IsStrictOrder X r` means that the binary relation `r` on `X` is a strict order, that is,
`IsIrrefl X r` and `IsTrans X r`. -/
class IsStrictOrder (α : Type u) (r : α → α → Prop) extends IsIrrefl α r, IsTrans α r : Prop

/-- `IsIncompTrans X lt` means that for `lt` a binary relation on `X`, the incomparable relation
`λ a b, ¬ lt a b ∧ ¬ lt b a` is transitive. -/
class IsIncompTrans (α : Type u) (lt : α → α → Prop) : Prop where
  incomp_trans : ∀ a b c, ¬lt a b ∧ ¬lt b a → ¬lt b c ∧ ¬lt c b → ¬lt a c ∧ ¬lt c a

/-- `IsStrictWeakOrder X lt` means that the binary relation `lt` on `X` is a strict weak order,
that is, `IsStrictOrder X lt` and `IsIncompTrans X lt`. -/
class IsStrictWeakOrder (α : Type u) (lt : α → α → Prop)
  extends IsStrictOrder α lt, IsIncompTrans α lt : Prop

/-- `IsTrichotomous X lt` means that the binary relation `lt` on `X` is trichotomous, that is,
either `lt a b` or `a = b` or `lt b a` for any `a` and `b`. -/
class IsTrichotomous (α : Type u) (lt : α → α → Prop) : Prop where
  trichotomous : ∀ a b, lt a b ∨ a = b ∨ lt b a

/-- `IsStrictTotalOrder X lt` means that the binary relation `lt` on `X` is a strict total order,
that is, `IsTrichotomous X lt` and `IsStrictOrder X lt`. -/
class IsStrictTotalOrder (α : Type u) (lt : α → α → Prop)
  extends IsTrichotomous α lt, IsStrictOrder α lt : Prop

/-- Equality is an equivalence relation. -/
instance eq_isEquiv (α : Type u) : IsEquiv α (· = ·) where
  symm := @Eq.symm _
  trans := @Eq.trans _
  refl := Eq.refl

section

variable {α : Type u} {r : α → α → Prop}

/-- Temporary notation for a relation. -/
local infixl:50 "≺" => r

theorem irrefl [IsIrrefl α r] (a : α) : ¬a ≺ a :=
  IsIrrefl.irrefl a

theorem refl [IsRefl α r] (a : α) : a ≺ a :=
  IsRefl.refl a

theorem trans [IsTrans α r] {a b c : α} : a ≺ b → b ≺ c → a ≺ c :=
  IsTrans.trans _ _ _

theorem symm [IsSymm α r] {a b : α} : a ≺ b → b ≺ a :=
  IsSymm.symm _ _

theorem antisymm [IsAntisymm α r] {a b : α} : a ≺ b → b ≺ a → a = b :=
  IsAntisymm.antisymm _ _

theorem asymm [IsAsymm α r] {a b : α} : a ≺ b → ¬b ≺ a :=
  IsAsymm.asymm _ _

theorem trichotomous [IsTrichotomous α r] : ∀ a b : α, a ≺ b ∨ a = b ∨ b ≺ a :=
  IsTrichotomous.trichotomous

theorem incomp_trans [IsIncompTrans α r] {a b c : α} :
    ¬a ≺ b ∧ ¬b ≺ a → ¬b ≺ c ∧ ¬c ≺ b → ¬a ≺ c ∧ ¬c ≺ a :=
  IsIncompTrans.incomp_trans _ _ _

instance (priority := 90) isAsymm_of_isTrans_of_isIrrefl [IsTrans α r] [IsIrrefl α r] :
    IsAsymm α r :=
  ⟨fun a _ h₁ h₂ ↦ absurd (_root_.trans h₁ h₂) (irrefl a)⟩

section ExplicitRelationVariants

variable (r)

@[elab_without_expected_type]
theorem irrefl_of [IsIrrefl α r] (a : α) : ¬a ≺ a :=
  irrefl a

@[elab_without_expected_type]
theorem refl_of [IsRefl α r] (a : α) : a ≺ a :=
  refl a

@[elab_without_expected_type]
theorem trans_of [IsTrans α r] {a b c : α} : a ≺ b → b ≺ c → a ≺ c :=
  _root_.trans

@[elab_without_expected_type]
theorem symm_of [IsSymm α r] {a b : α} : a ≺ b → b ≺ a :=
  symm

@[elab_without_expected_type]
theorem asymm_of [IsAsymm α r] {a b : α} : a ≺ b → ¬b ≺ a :=
  asymm

@[elab_without_expected_type]
theorem total_of [IsTotal α r] (a b : α) : a ≺ b ∨ b ≺ a :=
  IsTotal.total _ _

@[elab_without_expected_type]
theorem trichotomous_of [IsTrichotomous α r] : ∀ a b : α, a ≺ b ∨ a = b ∨ b ≺ a :=
  trichotomous

@[elab_without_expected_type]
theorem incomp_trans_of [IsIncompTrans α r] {a b c : α} :
    ¬a ≺ b ∧ ¬b ≺ a → ¬b ≺ c ∧ ¬c ≺ b → ¬a ≺ c ∧ ¬c ≺ a :=
  incomp_trans

end ExplicitRelationVariants

end

-- Porting note: the `StrictWeakOrder` section has been ommitted.

-- namespace StrictWeakOrder

-- section

-- parameter {α : Type u}{r : α → α → Prop}

-- -- mathport name: «expr ≺ »
-- local infixl:50 "≺" => r

-- def Equiv (a b : α) : Prop :=
--   ¬a ≺ b ∧ ¬b ≺ a

-- parameter [IsStrictWeakOrder α r]

-- -- mathport name: equiv
-- local infixl:50 " ≈ " => equiv

-- theorem erefl (a : α) : a ≈ a :=
--   ⟨irrefl a, irrefl a⟩

-- theorem esymm {a b : α} : a ≈ b → b ≈ a := fun ⟨h₁, h₂⟩ ↦ ⟨h₂, h₁⟩

-- theorem etrans {a b c : α} : a ≈ b → b ≈ c → a ≈ c :=
--   incomp_trans

-- theorem not_lt_of_equiv {a b : α} : a ≈ b → ¬a ≺ b := fun h ↦ h.1

-- theorem not_lt_of_equiv' {a b : α} : a ≈ b → ¬b ≺ a := fun h ↦ h.2

-- instance is_equiv : IsEquiv α equiv where
--   refl := erefl
--   trans := @etrans
--   symm := @esymm

-- end

-- -- mathport name: «expr ≈[ ] »
-- notation:50 -- Notation for the equivalence relation induced by lt
-- a " ≈[" lt "]" b:50 => @Equiv _ lt a b

-- end StrictWeakOrder

theorem isStrictWeakOrder_of_isTotalPreorder {α : Type u} {le : α → α → Prop}
    {lt : α → α → Prop} [DecidableRel le] [IsTotalPreorder α le] (h : ∀ a b, lt a b ↔ ¬le b a) :
    IsStrictWeakOrder α lt :=
  { trans := fun a b c hab hbc ↦
      have nba : ¬le b a := Iff.mp (h _ _) hab
      have ncb : ¬le c b := Iff.mp (h _ _) hbc
      have hab : le a b := Or.resolve_left (total_of le b a) nba
      have nca : ¬le c a := fun hca : le c a ↦
        have hcb : le c b := trans_of le hca hab
        absurd hcb ncb
      Iff.mpr (h _ _) nca,
    irrefl := fun a hlt ↦ absurd (refl_of le a) (Iff.mp (h _ _) hlt),
    incomp_trans := fun a b c ⟨nab, nba⟩ ⟨nbc, ncb⟩ ↦
      have hba : le b a := Decidable.of_not_not (Iff.mp (not_congr (h _ _)) nab)
      have hab : le a b := Decidable.of_not_not (Iff.mp (not_congr (h _ _)) nba)
      have hcb : le c b := Decidable.of_not_not (Iff.mp (not_congr (h _ _)) nbc)
      have hbc : le b c := Decidable.of_not_not (Iff.mp (not_congr (h _ _)) ncb)
      have hac : le a c := trans_of le hab hbc
      have hca : le c a := trans_of le hcb hba
      And.intro (fun n ↦ absurd hca (Iff.mp (h _ _) n)) fun n ↦ absurd hac (Iff.mp (h _ _) n) }

theorem lt_of_lt_of_incomp {α : Type u} {lt : α → α → Prop} [IsStrictWeakOrder α lt]
    [DecidableRel lt] : ∀ {a b c}, lt a b → ¬lt b c ∧ ¬lt c b → lt a c :=
  @fun a b c hab ⟨nbc, ncb⟩ ↦
  have nca : ¬lt c a := fun hca ↦ absurd (trans_of lt hca hab) ncb
  Decidable.by_contradiction fun nac : ¬lt a c ↦
    have : ¬lt a b ∧ ¬lt b a := incomp_trans_of lt ⟨nac, nca⟩ ⟨ncb, nbc⟩
    absurd hab this.1

theorem lt_of_incomp_of_lt {α : Type u} {lt : α → α → Prop} [IsStrictWeakOrder α lt]
    [DecidableRel lt] : ∀ {a b c}, ¬lt a b ∧ ¬lt b a → lt b c → lt a c :=
  @fun a b c ⟨nab, nba⟩ hbc ↦
  have nca : ¬lt c a := fun hca ↦ absurd (trans_of lt hbc hca) nba
  Decidable.by_contradiction fun nac : ¬lt a c ↦
    have : ¬lt b c ∧ ¬lt c b := incomp_trans_of lt ⟨nba, nab⟩ ⟨nac, nca⟩
    absurd hbc this.1

theorem eq_of_incomp {α : Type u} {lt : α → α → Prop} [IsTrichotomous α lt] {a b} :
    ¬lt a b ∧ ¬lt b a → a = b :=
  fun ⟨nab, nba⟩ ↦
  match trichotomous_of lt a b with
  | Or.inl hab => absurd hab nab
  | Or.inr (Or.inl hab) => hab
  | Or.inr (Or.inr hba) => absurd hba nba

theorem eq_of_eqv_lt {α : Type u} {lt : α → α → Prop} [IsTrichotomous α lt] {a b} :
    ¬lt a b ∧ ¬lt b a → a = b :=
  eq_of_incomp

theorem incomp_iff_eq {α : Type u} {lt : α → α → Prop} [IsTrichotomous α lt] [IsIrrefl α lt] (a b) :
    ¬lt a b ∧ ¬lt b a ↔ a = b :=
  Iff.intro eq_of_incomp fun hab ↦ by
    rw [hab]
    exact ⟨irrefl_of lt b, irrefl_of lt b⟩

theorem eqv_lt_iff_eq {α : Type u} {lt : α → α → Prop} [IsTrichotomous α lt] [IsIrrefl α lt] (a b) :
    ¬lt a b ∧ ¬lt b a ↔ a = b :=
  incomp_iff_eq a b

theorem not_lt_of_lt {α : Type u} {lt : α → α → Prop} [IsStrictOrder α lt] {a b} :
    lt a b → ¬lt b a :=
  fun h₁ h₂ ↦ absurd (trans_of lt h₁ h₂) (irrefl_of lt _)


import algebra.category.Group.colimits
import lemmas.ulift
import new.unordered.d

section

open topological_space Top Top.sheaf
open category_theory
open opposite
open nat

open_locale big_operators

universe u
variables {X : Top.{u}} (𝓕 : sheaf Ab X) (U V : X.oc)
variable (n : ℕ)

section

variables {n U V} (r : U ⟶ V)

def vec.refine (α : fin n → U.ι) : fin n → V.ι :=
r.func ∘ α

lemma vec.refine_apply (α : fin n → U.ι) (m : fin n) :
  vec.refine r α m = r.func (α m) := rfl

lemma vec.refine_comp_apply {U V W : X.oc} (r : U ⟶ V) (r' : V ⟶ W)
  (α : fin n → U.ι) (m : fin n) :
  vec.refine (r ≫ r') α m = vec.refine r' (vec.refine r α) m := rfl

lemma vec.refine_le (α : fin n → U.ι) :
  face α ≤ face (vec.refine r α) :=
begin
  intros p hp,
  rw opens.mem_coe at hp ⊢,
  unfold face at hp ⊢,
  rw opens.fintype_infi at hp ⊢,
  intros i,
  specialize hp i,
  apply r.is_refinement,
  exact hp,
end

lemma vec.refine_ignore (α : fin (n + 1) → U.ι) (k : fin (n + 1)) :
  vec.refine r (ignore α k) = ignore (vec.refine r α) k :=
begin
  ext1 m,
  rw vec.refine_apply,
  rw ignore.apply_ite,
  rw ignore.apply_ite,
  split_ifs,
  rw vec.refine_apply,
  rw vec.refine_apply,
end

variables {𝓕}
def C.refine.to_fun (f : C 𝓕 V n) : C 𝓕 U n :=
λ α, 𝓕.1.map (hom_of_le (vec.refine_le r α)).op (f (vec.refine r α))

lemma C.refine.to_fun_apply (f : C 𝓕 V n) (α : fin n → U.ι) :
  C.refine.to_fun r f α = 𝓕.1.map (hom_of_le (vec.refine_le r α)).op (f (vec.refine r α)) :=
rfl

def C.refine : C 𝓕 V n ⟶ C 𝓕 U n :=
{ to_fun := λ f, C.refine.to_fun r f,
  map_zero' := begin
    ext α,
    rw C.refine.to_fun_apply,
    simp only [C_pre.zero_apply, map_zero],
  end,
  map_add' := λ f g, begin
    ext α,
    rw [C.refine.to_fun_apply, pi.add_apply, map_add],
    refl,
  end }

lemma C.refine_d_eq_d_refine :
  C.refine r ≫ d 𝓕 U n = d 𝓕 V n ≫ C.refine r :=
begin
  ext f α,
  rw [comp_apply, comp_apply],
  rw [dd_aux.d_def],
  rw [C.refine, C.refine, add_monoid_hom.coe_mk, add_monoid_hom.coe_mk, C.refine.to_fun_apply],
  simp_rw [C.refine.to_fun_apply],
  rw [dd_aux.d_def],
  rw add_monoid_hom.map_sum,
  rw finset.sum_congr rfl,
  intros i _,
  split_ifs,
  { rw [id, ← comp_apply, ← 𝓕.1.map_comp, ← comp_apply, ← 𝓕.1.map_comp],
    rw map_congr.vec_eq f (_ : vec.refine r (ignore α i) = ignore (vec.refine r α) i),
    rw [← comp_apply, ← 𝓕.1.map_comp],
    congr,
    rw vec.refine_ignore, },
  { rw [pi.neg_apply, pi.neg_apply],
    simp only [pi.neg_apply, add_monoid_hom.neg_apply, map_neg, neg_inj],
    rw [← comp_apply, ← comp_apply, ← 𝓕.1.map_comp, ← 𝓕.1.map_comp],
    rw map_congr.vec_eq f (_ : vec.refine r (ignore α i) = ignore (vec.refine r α) i),
    rw [← comp_apply, ← 𝓕.1.map_comp],
    congr,
    rw vec.refine_ignore, },
end

lemma C.refine_d_eq_d_refine' (f) :
  C.refine r (d 𝓕 V n f)  = d 𝓕 U n (C.refine r f) :=
begin
  rw ← comp_apply,
  rw ← C.refine_d_eq_d_refine,
  rw comp_apply,
end

lemma C.refine_eq_to_hom {m n : ℕ} (h0 : m + 1 = n) (h1 : C 𝓕 U (m + 1) = C 𝓕 U n) (h2 : C 𝓕 V (m + 1) = C 𝓕 V n) :
  (@C.refine X 𝓕 U V (m+1) r ≫ eq_to_hom h1) = eq_to_hom h2 ≫ @C.refine X 𝓕 U V n r :=
begin
  ext f α,
  rw [comp_apply, comp_apply, C.refine, add_monoid_hom.coe_mk,  C.refine, add_monoid_hom.coe_mk, C.refine.to_fun_apply],

  have : @eq_to_hom Ab _ _ _ h2 f (vec.refine r α) = 𝓕.1.map _ (f (vec.refine r (λ i, α ⟨i.1, h0 ▸ i.2⟩))),
  work_on_goal 3
  { refine quiver.hom.op _,
    refine eq_to_hom _,
    sorry },
  { sorry },
  rw this,
  have : (@eq_to_hom Ab _ _ _ h1 (C.refine.to_fun r f)) α = 𝓕.1.map _ (C.refine.to_fun r f (λ i, α ⟨i.1, h0 ▸ i.2⟩)),
  work_on_goal 3
  { refine quiver.hom.op _,
    refine eq_to_hom _,
    unfold face,
    ext,
    split,

    { intros hp,
      rw opens.mem_coe at hp ⊢,
      rw opens.fintype_infi at hp ⊢,
      intros i,
      specialize hp ⟨i.1, h0 ▸ i.2⟩,
      exact hp },
    { intros hp,
      rw opens.mem_coe at hp ⊢,
      rw opens.fintype_infi at hp ⊢,
      intros i,
      specialize hp ⟨i.1, h0.symm ▸ i.2⟩,
      convert hp,
      rw subtype.ext_iff_val, }, },

  { sorry },
  rw this,
  rw ← comp_apply,
  rw ← 𝓕.1.map_comp,
  rw C.refine.to_fun_apply,
  rw ← comp_apply,
  rw ← 𝓕.1.map_comp,
  congr,
end

def C.refine_functor : X.ocᵒᵖ ⥤ Ab :=
{ obj := λ U, C 𝓕 (unop U) n,
  map := λ U V r, C.refine r.unop,
  map_id' := λ U, begin
    ext f α,
    simp only [unop_id, id_apply],
    change C.refine.to_fun _ f α = _,
    rw C.refine.to_fun_apply,
    rw map_congr.vec_eq f (_ : α = vec.refine (𝟙 _) α),
    congr,
    ext m,
    rw vec.refine_apply,
    refl,
  end,
  map_comp' := λ U V W rUV rVW, begin
    ext f α,
    rw comp_apply,
    change C.refine.to_fun _ f α = _,
    rw C.refine.to_fun_apply,
    rw C.refine,
    simp only [add_monoid_hom.coe_mk],
    rw C.refine,
    simp only [add_monoid_hom.coe_mk],

    rw C.refine.to_fun_apply,
    rw C.refine.to_fun_apply,
    rw ← comp_apply,
    rw ← 𝓕.1.map_comp,
    rw map_congr.vec_eq f (_ : vec.refine (rUV ≫ rVW).unop α = vec.refine rUV.unop (vec.refine rVW.unop α)),
    rw ← comp_apply,
    rw ← 𝓕.1.map_comp,
    congr,
    refl,
  end }

include 𝓕 n
noncomputable example : Ab :=
begin
  have := limits.colim.obj (@C.refine_functor _ 𝓕 n  ⋙ AddCommGroup.ulift_functor.{u u+1}),
  exact this,
end

end

end


import data.cpi.semantics.relation
import data.fin_fn

namespace cpi

/-- Determine if two concretions are equal. Effectively a decision procedure for
    structural congruence. -/
instance concretion_wrap.decidable_eq {ℍ ω Γ} [cpi_equiv ℍ ω] :
  decidable_eq ( prime_species' ℍ ω Γ
               × (Σ (b y : ℕ), concretion' ℍ ω Γ b y) × name Γ)
| a b := by apply_instance

/-- A vector-space representation of processes, mapping prime species into their
    concentrations. -/
@[nolint has_inhabited_instance]
def process_space (ℂ ℍ : Type) (ω Γ : context) [add_monoid ℂ] [cpi_equiv ℍ ω]
  := fin_fn (prime_species' ℍ ω Γ) ℂ

variables {ℂ ℍ : Type} {ω : context} [half_ring ℂ] [cpi_equiv ℍ ω] [decidable_eq ℂ]

instance process_space.add_comm_monoid {Γ} : add_comm_group (process_space ℂ ℍ ω Γ) := fin_fn.add_comm_group _ ℂ
instance process_space.semimodule {Γ} : semimodule ℂ (process_space ℂ ℍ ω Γ) := fin_fn.semimodule _ ℂ
instance process_space.has_repr {ℂ} [add_monoid ℂ] [has_repr ℂ] {Γ} [has_repr (species' ℍ ω Γ)]
  : has_repr (process_space ℂ ℍ ω Γ) := ⟨ fin_fn.to_string "\n" ⟩

/-- Convert a species into a process space with a unit vector for each element
    of the prime decomposition.

    This is defined as ⟨A⟩ within the paper. -/
def to_process_space {Γ} (A : species' ℍ ω Γ) : process_space ℂ ℍ ω Γ
  := (cpi_equiv.prime_decompose' A).sum' (λ A, fin_fn.single A 1)

@[simp]
lemma to_process_space.nil {Γ} : to_process_space ⟦nil⟧ = (0 : process_space ℂ ℍ ω Γ)
  := by simp only [to_process_space, cpi_equiv.prime_decompose_nil', multiset.sum'_zero]

@[simp]
lemma to_process_space.prime {Γ} (A : prime_species' ℍ ω Γ)
  : (to_process_space (prime_species.unwrap A) : process_space ℂ ℍ ω Γ)
  = fin_fn.single A 1
  := by simp only [to_process_space, cpi_equiv.prime_decompose_prime', multiset.sum'_singleton]

@[simp]
lemma to_process_space.parallel {Γ} (A B : species ℍ ω Γ)
  : (to_process_space ⟦ A |ₛ B ⟧ : process_space ℂ ℍ ω Γ)
  = to_process_space ⟦ A ⟧ + to_process_space ⟦ B ⟧
  := by simp only [to_process_space, cpi_equiv.prime_decompose_parallel', multiset.sum'_add]

/-- The vector space (A, E, a)→ℍ relating transitions from A to E with label #a.
  -/
@[nolint has_inhabited_instance]
def interaction_space (ℂ ℍ : Type) (ω Γ : context) [add_monoid ℂ] [cpi_equiv ℍ ω] : Type
  := fin_fn
      ( prime_species' ℍ ω Γ
      × (Σ (b y), concretion' ℍ ω Γ b y)
      × name Γ)
      ℂ

instance interaction_space.add_comm_monoid {Γ} : add_comm_group (interaction_space ℂ ℍ ω Γ) := fin_fn.add_comm_group _ ℂ
instance interaction_space.semimodule {Γ} : semimodule ℂ (interaction_space ℂ ℍ ω Γ) := fin_fn.semimodule _ ℂ

instance interaction_space.has_repr {ℂ} [add_monoid ℂ] [has_repr ℂ] {Γ}
  [has_repr (species' ℍ ω Γ)] [∀ b y, has_repr (concretion' ℍ ω Γ b y)]
  : has_repr (interaction_space ℂ ℍ ω Γ) := ⟨ @fin_fn.to_string
    ( prime_species' ℍ ω Γ
      × (Σ (b y), concretion' ℍ ω Γ b y)
      × name Γ) ℂ _
    ⟨ λ ⟨ A, ⟨ _, _, F ⟩, a ⟩, "[" ++ repr A ++ "], [" ++ repr F ++ "], " ++ repr a ⟩
    _ "\n" ⟩

/-- Convert a process into a process space. -/
def process.to_space {Γ}
  : process ℂ ℍ ω Γ → process_space ℂ ℍ ω Γ
| (c ◯ A) := c • to_process_space ⟦ A ⟧
| (P |ₚ Q) := process.to_space P + process.to_space Q

/-- Convert a process space into a process. -/
def process.from_space {ℂ} [add_comm_monoid ℂ] {Γ} : process_space ℂ ℍ ω Γ → process' ℂ ℍ ω Γ
| Ps := process.from_prime_multiset Ps.space Ps.support.val

/-- Convert a class of equivalent processes into a process space. -/
def process.to_space' {Γ} : process' ℂ ℍ ω Γ → process_space ℂ ℍ ω Γ
| P := quot.lift_on P process.to_space (λ P Q eq, begin
  induction eq,
  case process.equiv.refl { from rfl },
  case process.equiv.trans : P Q R _ _ pq qr { from trans pq qr },
  case process.equiv.symm : P Q _ ih { from symm ih },

  case process.equiv.ξ_species : c A A' eq {
    simp only [process.to_space, quotient.sound eq],
  },
  case process.equiv.ξ_parallel₁ : P P' Q _ ih { simp only [process.to_space, ih] },
  case process.equiv.ξ_parallel₂ : P Q Q' _ ih { simp only [process.to_space, ih] },

  case process.equiv.parallel_nil : P c {
    simp only [process.to_space, cpi.to_process_space.nil, smul_zero, add_zero],
  },
  case process.equiv.parallel_symm { simp only [process.to_space, add_comm] },
  case process.equiv.parallel_assoc { simp only [process.to_space, add_assoc] },
  case cpi.process.equiv.join : A c d { simp only [process.to_space, add_smul] },
  case cpi.process.equiv.split : A B c {
    simp only [process.to_space, to_process_space.parallel, smul_add],
  }
end)

axiom process.from_inverse {Γ} :
  function.left_inverse process.to_space' (@process.from_space ℍ ω _ ℂ _ Γ)

/-- Show that process spaces can be embeeded into equivalence classes of processes. -/
def process.space_embed {Γ} : process_space ℂ ℍ ω Γ ↪ process' ℂ ℍ ω Γ :=
  { to_fun := process.from_space,
    inj := function.injective_of_left_inverse process.from_inverse }

end cpi

#lint-


import data.finset data.multiset.dict data.pfun logic.function

local attribute [-simp] sigma.forall sigma.exists

universes u v

/-- Finite map: a multiset of dependent pairs with no duplicate keys -/
structure finmap (α : Type u) (β : α → Type v) : Type (max u v) :=
(val : multiset (sigma β))
(nodupkeys : val.nodupkeys)

namespace finmap
open multiset

section αβ
variables {α : Type u} {β : α → Type v}

/- equality -/

theorem eq_of_veq : ∀ {f g : finmap α β}, f.val = g.val → f = g
| ⟨s, _⟩ ⟨t, _⟩ h := by congr; exact h

@[simp] theorem val_inj {f g : finmap α β} : f.val = g.val ↔ f = g :=
⟨eq_of_veq, congr_arg _⟩

instance has_decidable_eq [decidable_eq α] [∀ a, decidable_eq (β a)] : decidable_eq (finmap α β)
| f g := decidable_of_iff _ val_inj

/- recursors -/

section rec
open function

/-- Dependent recursor on a finmap for a list -/
protected def lrec_on {γ : Sort*} (f : finmap α β)
  (φ : ∀ {l : list (sigma β)}, l.nodupkeys → γ)
  (c : ∀ {l₁ l₂} (p : l₁ ~ l₂) d₁ d₂, φ d₁ = φ d₂) : γ :=
@quotient.hrec_on _ _ (λ (m : multiset (sigma β)), m.nodupkeys → γ)
  f.val
  (λ l (d : l.nodupkeys), φ d)
  (λ l₁ l₂ p, hfunext (by rw list.perm_nodupkeys p) $ λ d₁ d₂ _, heq_of_eq $ c p d₁ d₂)
  f.nodupkeys

/-- Dependent recursor on two finmaps for lists -/
protected def lrec_on₂ {γ : Sort*} (f g : finmap α β)
  (φ : ∀ {l₁ l₂ : list (sigma β)}, l₁.nodupkeys → l₂.nodupkeys → γ)
  (c : ∀ {l₁ l₂ l₃ l₄} (p₁₃ : l₁ ~ l₃) (p₂₄ : l₂ ~ l₄) d₁ d₂ d₃ d₄, φ d₁ d₂ = φ d₃ d₄) : γ :=
@quotient.hrec_on₂ _ _ _ _
  (λ (m₁ m₂ : multiset (sigma β)), m₁.nodupkeys → m₂.nodupkeys → γ)
  f.val g.val
  (λ l₁ l₂ (d₁ : l₁.nodupkeys) (d₂ : l₂.nodupkeys), φ d₁ d₂)
  (λ l₁ l₂ l₃ l₄ p₁₃ p₂₄, hfunext (by rw list.perm_nodupkeys p₁₃) $
    λ d₁ d₃ _, hfunext (by rw list.perm_nodupkeys p₂₄) $
      λ d₂ d₄ _, heq_of_eq $ c p₁₃ p₂₄ d₁ d₂ d₃ d₄)
  f.nodupkeys g.nodupkeys

/-- Lift a function on 2 lists to a function on 2 finmaps  -/
protected def lift_on₂ {γ : Type*} (f g : finmap α β)
  (φ : ∀ {l₁ l₂ : list (sigma β)}, l₁.nodupkeys → l₂.nodupkeys → γ)
  (c : ∀ {l₁ l₂ l₃ l₄} (p₁₃ : l₁ ~ l₃) (p₂₄ : l₂ ~ l₄) d₁ d₂ d₃ d₄, φ d₁ d₂ = φ d₃ d₄) :
  roption γ :=
quotient.lift_on₂ f.val g.val
  (λ l₁ l₂, roption.mk (l₁.nodupkeys ∧ l₂.nodupkeys) (λ ⟨d₁, d₂⟩, φ d₁ d₂))
  (λ l₁ l₂ l₃ l₄ p₁₃ p₂₄, roption.ext'
    (and_congr (list.perm_nodupkeys p₁₃) (list.perm_nodupkeys p₂₄))
    (λ ⟨d₁, d₂⟩ ⟨d₃, d₄⟩, c p₁₃ p₂₄ d₁ d₂ d₃ d₄))

end rec

/- membership -/

section mem
variables {s : sigma β} {m : multiset (sigma β)} {d : m.nodupkeys} {f : finmap α β}

instance : has_mem (sigma β) (finmap α β) :=
⟨λ s f, s ∈ f.val⟩

theorem mem_def : s ∈ f ↔ s ∈ f.val :=
iff.rfl

@[simp] theorem mem_mk : @has_mem.mem _ (finmap α β) _ s (finmap.mk m d) ↔ s ∈ m :=
iff.rfl

instance decidable_mem [decidable_eq α] [∀ a, decidable_eq (β a)] (s : sigma β) (f : finmap α β) :
  decidable (s ∈ f) :=
multiset.decidable_mem _ _

end mem

/- set coercion -/

section set
variables {s : sigma β} {f : finmap α β}

def to_set (f : finmap α β) : set (sigma β) :=
{x | x ∈ f}

instance has_lift_set : has_lift (finmap α β) (set (sigma β)) :=
⟨to_set⟩

@[simp] theorem mem_set_coe : s ∈ (↑f : set (sigma β)) ↔ s ∈ f :=
iff.rfl

end set

/- finset coercion -/

section finset
variables {s : sigma β} {f : finmap α β}

def to_finset (f : finmap α β) : finset (sigma β) :=
⟨f.val, nodup_of_nodupkeys f.nodupkeys⟩

instance has_lift_finset : has_lift (finmap α β) (finset (sigma β)) :=
⟨to_finset⟩

@[simp] theorem mem_finset_coe : s ∈ (↑f : finset (sigma β)) ↔ s ∈ f :=
iff.rfl

end finset

/- extensionality -/

section ext
variables {f g : finmap α β}

theorem ext : f = g ↔ ∀ s, s ∈ f ↔ s ∈ g :=
val_inj.symm.trans $ nodup_ext
  (nodup_of_nodupkeys f.nodupkeys)
  (nodup_of_nodupkeys g.nodupkeys)

@[extensionality]
theorem ext' : (∀ s, s ∈ f ↔ s ∈ g) → f = g :=
ext.mpr

end ext

/- subset -/

section subset
variables {s : sigma β} {f g h : finmap α β}

instance : has_subset (finmap α β) :=
⟨λ f g, ∀ ⦃s : sigma β⦄, s ∈ f → s ∈ g⟩

theorem subset_def : f ⊆ g ↔ f.val ⊆ g.val :=
iff.rfl

@[simp] theorem subset.refl (f : finmap α β) : f ⊆ f :=
subset.refl _

theorem subset.trans : f ⊆ g → g ⊆ h → f ⊆ h :=
subset.trans

theorem mem_of_subset : f ⊆ g → s ∈ f → s ∈ g :=
mem_of_subset

theorem subset.antisymm (H₁ : f ⊆ g) (H₂ : g ⊆ f) : f = g :=
ext' $ λ a, ⟨@H₁ a, @H₂ a⟩

theorem subset_iff : f ⊆ g ↔ ∀ ⦃x⦄, x ∈ f → x ∈ g :=
iff.rfl

@[simp] theorem coe_subset_set : (↑f : set (sigma β)) ⊆ ↑g ↔ f ⊆ g :=
iff.rfl

@[simp] theorem coe_subset_finset : (↑f : finset (sigma β)) ⊆ ↑g ↔ f ⊆ g :=
iff.rfl

@[simp] theorem val_le_iff : f.val ≤ g.val ↔ f ⊆ g :=
le_iff_subset (nodup_of_nodupkeys f.nodupkeys)

instance : has_ssubset (finmap α β) :=
⟨λa b, a ⊆ b ∧ ¬ b ⊆ a⟩

instance : partial_order (finmap α β) :=
{ le := (⊆),
  lt := (⊂),
  le_refl := subset.refl,
  le_trans := @subset.trans _ _,
  le_antisymm := @subset.antisymm _ _ }

@[simp] theorem le_iff_subset : f ≤ g ↔ f ⊆ g := iff.rfl
@[simp] theorem lt_iff_ssubset : f < g ↔ f ⊂ g := iff.rfl

@[simp] theorem val_lt_iff : f.val < g.val ↔ f ⊂ g :=
and_congr val_le_iff $ not_congr val_le_iff

end subset

/- empty -/

section empty
variables {s : sigma β} {f : finmap α β}

instance : has_emptyc (finmap α β) :=
⟨⟨_, nodupkeys_zero⟩⟩

instance : inhabited (finmap α β) :=
⟨∅⟩

@[simp] theorem empty_val : (∅ : finmap α β).val = 0 :=
rfl

@[simp] theorem not_mem_empty (s : sigma β) : s ∉ (∅ : finmap α β) :=
id

@[simp] theorem ne_empty_of_mem (h : s ∈ f) : f ≠ ∅
| e := not_mem_empty s $ e ▸ h

@[simp] theorem empty_subset (f : finmap α β) : ∅ ⊆ f :=
zero_subset _

theorem eq_empty_of_forall_not_mem (H : ∀x, x ∉ f) : f = ∅ :=
eq_of_veq (eq_zero_of_forall_not_mem H)

@[simp] theorem val_eq_zero : f.val = 0 ↔ f = ∅ :=
@val_inj _ _ f ∅

theorem subset_empty : f ⊆ ∅ ↔ f = ∅ :=
subset_zero.trans val_eq_zero

theorem exists_mem_of_ne_empty (h : f ≠ ∅) : ∃ s : sigma β, s ∈ f :=
exists_mem_of_ne_zero (mt val_eq_zero.mp h)

@[simp] theorem coe_empty_set : ↑(∅ : finmap α β) = (∅ : set (sigma β)) :=
by simp [set.ext_iff]

@[simp] theorem coe_empty_finset : ↑(∅ : finmap α β) = (∅ : finset (sigma β)) :=
by simp [finset.ext]

end empty

/- singleton -/

section singleton
variables {s₁ s₂ : sigma β}

/-- `singleton s` is the set `{s}` containing `s` and nothing else. -/
def singleton (s : sigma β) : finmap α β :=
⟨⟦[s]⟧, nodupkeys_singleton s⟩

@[simp] theorem singleton_val (s : sigma β) : (singleton s).val = s :: 0 :=
rfl

@[simp] theorem mem_singleton : s₁ ∈ singleton s₂ ↔ s₁ = s₂ :=
by simp [singleton]

theorem not_mem_singleton : s₁ ∉ singleton s₂ ↔ s₁ ≠ s₂ := by simp

theorem mem_singleton_self (s : sigma β) : s ∈ singleton s := by simp

theorem singleton_inj : singleton s₁ = singleton s₂ ↔ s₁ = s₂ :=
⟨λ h, mem_singleton.mp (h ▸ mem_singleton_self _), congr_arg _⟩

@[simp] theorem singleton_ne_empty (s : sigma β) : singleton s ≠ ∅ :=
ne_empty_of_mem (mem_singleton_self _)

@[simp] theorem coe_singleton_set (s : sigma β) : ↑(singleton s) = ({s} : set (sigma β)) :=
by simp [set.ext_iff]

@[simp] theorem coe_singleton_finset (s : sigma β) : ↑(singleton s) = finset.singleton s :=
by simp [finset.ext]

end singleton

/- keys -/

section keys
variables {a a₁ a₂ : α} {s : sigma β} {f : finmap α β}

def keys (f : finmap α β) : finset α :=
⟨f.val.keys, nodupkeys_iff.mpr f.nodupkeys⟩

@[simp] theorem keys_val (f : finmap α β) : f.keys.val = f.val.keys :=
rfl

@[simp] theorem keys_empty : keys (∅ : finmap α β) = ∅ :=
rfl

@[simp] theorem keys_singleton : keys (singleton s) = finset.singleton s.1 :=
rfl

theorem mem_keys_of_mem : s ∈ f → s.1 ∈ f.keys :=
mem_keys_of_mem

theorem exists_mem_of_mem_keys : a ∈ f.keys → ∃ (b : β a), sigma.mk a b ∈ f :=
exists_mem_of_mem_keys

@[simp] theorem mem_keys_singleton : a ∈ (singleton s).keys ↔ a = s.1 :=
by simp

@[simp] theorem mem_insert_keys [decidable_eq α] :
  a₁ ∈ insert a₂ f.keys ↔ a₁ = a₂ ∨ a₁ ∈ f.keys :=
by simp

end keys

section decidable_eq_α
variables [decidable_eq α]

/- erase -/

section erase
variables {s : sigma β} {a a₁ a₂ : α} {f g : finmap α β}

def erase (f : finmap α β) (a : α) : finmap α β :=
⟨kerase a f.nodupkeys, nodupkeys_kerase a f.nodupkeys⟩

@[simp] theorem erase_val (f : finmap α β) (a : α) : (f.erase a).val = kerase a f.nodupkeys :=
rfl

@[simp] theorem mem_erase : s ∈ f.erase a ↔ s.1 ≠ a ∧ s ∈ f :=
mem_kerase f.nodupkeys

theorem not_mem_erase (a : α) (b : β a) (f : finmap α β) : sigma.mk a b ∉ f.erase a :=
by simp

@[simp] theorem mem_keys_erase : a₁ ∈ (f.erase a₂).keys ↔ a₁ ≠ a₂ ∧ a₁ ∈ f.keys :=
by simp [keys]

@[simp] theorem erase_empty (β : α → Type v) (a) : erase ∅ a = (∅ : finmap α β) :=
rfl

theorem ne_of_mem_erase : s ∈ f.erase a → s.1 ≠ a :=
by simp {contextual := tt}

theorem erase_subset_erase (a : α) (h : f ⊆ g) : f.erase a ⊆ g.erase a :=
val_le_iff.mp $ kerase_le_kerase _ (val_le_iff.mpr h) _ _

theorem erase_subset (a : α) : f.erase a ⊆ f :=
kerase_subset a f.nodupkeys

end erase

/- insert -/

section insert
variables {a : α} {s : sigma β} {f g : finmap α β}

instance : has_insert (sigma β) (finmap α β) :=
⟨λ s f, ⟨kinsert s f.nodupkeys, nodupkeys_kinsert s f.nodupkeys⟩⟩

theorem insert_def (s : sigma β) (f : finmap α β) :
  insert s f = mk (kinsert s f.nodupkeys) (nodupkeys_kinsert s f.nodupkeys) :=
rfl

@[simp] theorem insert_val (s : sigma β) (f : finmap α β) :
  (insert s f).val = kinsert s f.nodupkeys :=
rfl

@[simp] theorem insert_empty (s : sigma β) : insert s (∅ : finmap α β) = {s} :=
rfl

@[simp] theorem mem_insert (s₁ s₂ : sigma β) (f : finmap α β) :
  s₁ ∈ insert s₂ f ↔ s₁ = s₂ ∨ s₁ ∈ f.erase s₂.1 :=
mem_kinsert f.nodupkeys

@[simp] theorem mem_keys_insert : a ∈ (insert s f).keys ↔ a = s.1 ∨ a ∈ f.keys :=
by simp [keys]

@[simp] theorem insert_keys : (insert s f).keys = insert s.1 f.keys :=
finset.ext' $ by simp

@[simp] theorem disjoint_keys_insert_left :
  disjoint (insert s f).keys g.keys ↔ s.1 ∉ g.keys ∧ disjoint f.keys g.keys :=
by simp

@[simp] theorem disjoint_keys_insert_right :
  disjoint f.keys (insert s g).keys ↔ s.1 ∉ f.keys ∧ disjoint f.keys g.keys :=
by simp

end insert

/- lookup -/

section lookup

/-- Look up a key in a finmap to find the value, if it exists -/
def lookup (a : α) (f : finmap α β) : option (β a) :=
klookup a f.nodupkeys

/-- Treat a finmap as the function `∀ a, option (β a)` -/
def to_fun (f : finmap α β) (a : α) : option (β a) :=
f.lookup a

/-- Treat a finmap as the partial function `∀ a, roption (β a)` -/
def to_pfun (f : finmap α β) (a : α) : roption (β a) :=
roption.of_option (f.to_fun a)

theorem lookup_empty (β : α → Type v) (a) : lookup a (∅ : finmap α β) = none :=
rfl

end lookup

/- replace -/

section replace

def replace (s : sigma β) (f : finmap α β) : finmap α β :=
⟨kreplace s f.nodupkeys, nodupkeys_kreplace s f.nodupkeys⟩

@[simp] theorem replace_empty (s : sigma β) : replace s ∅ = ∅ :=
rfl

end replace

/- union -/

section union
variables {a : α} {s : sigma β} {f g h : finmap α β}

protected def union (f : finmap α β) (g : finmap α β) : finmap α β :=
⟨kunion f.nodupkeys g.nodupkeys, nodupkeys_kunion f.nodupkeys g.nodupkeys⟩

instance : has_union (finmap α β) :=
⟨finmap.union⟩

@[simp] theorem union_val : (f ∪ g).val = kunion f.nodupkeys g.nodupkeys :=
rfl

@[simp] theorem empty_union (f : finmap α β) : ∅ ∪ f = f :=
eq_of_veq $ by simp [zero_kunion f.nodupkeys]

@[simp] theorem union_empty (f : finmap α β) : f ∪ ∅ = f :=
eq_of_veq $ kunion_zero f.nodupkeys

@[simp] theorem insert_union : insert s f ∪ g = insert s (f ∪ g) :=
eq_of_veq $ kinsert_kunion f.nodupkeys g.nodupkeys

theorem mem_of_mem_union : s ∈ f ∪ g → s ∈ f ∨ s ∈ g :=
mem_of_mem_kunion f.nodupkeys g.nodupkeys

theorem mem_union_left (g : finmap α β) : s ∈ f → s ∈ f ∪ g :=
mem_kunion_left f.nodupkeys g.nodupkeys

theorem mem_union_right : s.1 ∉ f.keys → s ∈ g → s ∈ f ∪ g :=
mem_kunion_right f.nodupkeys g.nodupkeys

@[simp] theorem mem_union (dk : disjoint f.keys g.keys) : s ∈ f ∪ g ↔ s ∈ f ∨ s ∈ g :=
mem_kunion f.nodupkeys g.nodupkeys (finset.disjoint_val.mp dk)

theorem union_comm (dk : disjoint f.keys g.keys) : f ∪ g = g ∪ f :=
by simp [ext, or_comm, dk, dk.symm]

@[simp] theorem mem_keys_union : a ∈ (f ∪ g).keys ↔ a ∈ f.keys ∨ a ∈ g.keys :=
mem_keys_kunion f.nodupkeys g.nodupkeys

@[simp] theorem union_keys : (f ∪ g).keys = f.keys ∪ g.keys :=
finset.ext' $ by simp

theorem disjoint_keys_union_left :
  disjoint (f ∪ g).keys h.keys ↔ disjoint f.keys h.keys ∧ disjoint g.keys h.keys :=
by simp

theorem disjoint_keys_union_right :
  disjoint f.keys (g ∪ h).keys ↔ disjoint f.keys g.keys ∧ disjoint f.keys h.keys :=
by simp

@[simp] theorem union_assoc (dk_fg : disjoint f.keys g.keys) (dk_gh : disjoint g.keys h.keys)
  (dk_fh : disjoint f.keys h.keys) : (f ∪ g) ∪ h = f ∪ (g ∪ h) :=
have disjoint (f ∪ g).keys h.keys := disjoint_keys_union_left.mpr ⟨dk_fh, dk_gh⟩,
have disjoint f.keys (g ∪ h).keys := disjoint_keys_union_right.mpr ⟨dk_fg, dk_fh⟩,
by simp [ext, or_comm, or.left_comm, *]

theorem mem_union_middle_left (dk_fh : disjoint f.keys h.keys) (dk_gh : disjoint g.keys h.keys)
  (p : s ∈ f ∪ h) : s ∈ f ∪ g ∪ h :=
match mem_of_mem_union p with
| or.inl p := mem_union_left _ (mem_union_left _ p)
| or.inr p := mem_union_right
  (finset.disjoint_right.mp (disjoint_keys_union_left.mpr ⟨dk_fh, dk_gh⟩) (mem_keys_of_mem p)) p
end

theorem mem_union_middle_right (dk_fh : disjoint f.keys h.keys) (dk_gh : disjoint g.keys h.keys)
  (p : s ∈ f ∪ h) : s ∈ f ∪ (g ∪ h) :=
match mem_of_mem_union p with
| or.inl p := mem_union_left _ p
| or.inr p :=
  have s.1 ∈ h.keys := mem_keys_of_mem p,
  mem_union_right
    (finset.disjoint_right.mp dk_fh this)
    (mem_union_right (finset.disjoint_right.mp dk_gh this) p)
end

end union

end decidable_eq_α

end αβ

section α₁α₂α₃β₁β₂β₃
variables {α₁ α₂ α₃ : Type u} {β₁ : α₁ → Type v} {β₂ : α₂ → Type v} {β₃ : α₃ → Type v}

section map
variables {p : β₁ s↪ β₂} {q : β₂ s↪ β₃} {s₁ : sigma β₁} {s₂ : sigma β₂} {f g : finmap α₁ β₁}

def map (p : β₁ s↪ β₂) (f : finmap α₁ β₁) : finmap α₂ β₂ :=
⟨f.val.map p, nodupkeys_map p.fst_inj f.nodupkeys⟩

@[simp] theorem map_val (p : β₁ s↪ β₂) (f : finmap α₁ β₁) : (f.map p).val = f.val.map p :=
rfl

@[simp] theorem map_mk {m₁ : multiset (sigma β₁)} {m₂ : multiset (sigma β₂)} {p : β₁ s↪ β₂}
  (d₁ : m₁.nodupkeys) (d₂ : m₂.nodupkeys) : (mk m₁ d₁).map p = mk m₂ d₂ ↔ m₁.map p = m₂ :=
by simp [map]

@[simp] theorem map_empty (p : β₁ s↪ β₂) : map p ∅ = ∅ :=
rfl

@[simp] theorem mem_map : s₂ ∈ f.map p ↔ ∃ s₁ ∈ f, p s₁ = s₂ :=
by simp [mem_def]

@[simp] theorem mem_map_of_mem (h : s₁ ∈ f) : p s₁ ∈ f.map p :=
mem_map.mpr ⟨_, h, rfl⟩

theorem map_refl : f.map (sigma.embedding.refl _) = f :=
ext' $ by simp [sigma.embedding.refl]

theorem map_map : (f.map p).map q = f.map (p.trans q) :=
eq_of_veq $ by simp [erase_dup_map_erase_dup_eq]

theorem map_subset_map (h : f ⊆ g) : f.map p ⊆ g.map p :=
by simp [subset_def, map_subset_map h]

theorem mem_keys_map (pf : sigma.fst_functional p) :
  s₁.1 ∈ f.keys → (p s₁).1 ∈ (f.map p).keys :=
mem_keys_map pf

theorem mem_keys_of_mem_keys_map : (p s₁).1 ∈ (f.map p).keys → s₁.1 ∈ f.keys :=
mem_keys_of_mem_keys_map p.fst_inj

theorem mem_keys_map_iff (pf : sigma.fst_functional p) :
  (p s₁).1 ∈ (f.map p).keys ↔ s₁.1 ∈ f.keys :=
⟨mem_keys_of_mem_keys_map, mem_keys_map pf⟩

theorem map_disjoint_keys [decidable_eq α₁] [decidable_eq α₂] (pf : sigma.fst_functional p) :
  disjoint (f.map p).keys (g.map p).keys ↔ disjoint f.keys g.keys :=
by simp only [finset.disjoint_val]; exact multiset.map_disjoint_keys pf p.fst_inj

theorem map_union [decidable_eq α₁] [decidable_eq α₂] (pf : sigma.fst_functional p)
  (dk : disjoint f.keys g.keys) : (f ∪ g).map p = f.map p ∪ g.map p :=
ext' $ by simp [dk, map_disjoint_keys pf, or_and_distrib_right, exists_or_distrib]

section decidable_eq_α₁α₂
variables [decidable_eq α₁] [decidable_eq α₂]

@[simp] theorem map_erase (pf : sigma.fst_functional p) :
  (f.erase s₁.1).map p = (f.map p).erase (p s₁).1 :=
by simp [erase, map_kerase pf p.fst_inj f.nodupkeys]

@[simp] theorem map_insert (pf : sigma.fst_functional p) :
  (insert s₁ f).map p = insert (p s₁) (f.map p) :=
by simp [insert_def, map_kinsert pf p.fst_inj f.nodupkeys]

end decidable_eq_α₁α₂

end map

end α₁α₂α₃β₁β₂β₃

section αβ₁β₂
variables {α : Type u} {β₁ β₂ : α → Type v}

section map_id
variables {s : sigma β₁} {f : finmap α β₁}

@[simp] theorem map_id_val (p : ∀ a, β₁ a → β₂ a) (f : finmap α β₁) :
  (f.map (sigma.embedding.mk₂ p)).val = f.val.map (sigma.map id p) :=
rfl

@[simp] theorem map_id_keys (p : ∀ a, β₁ a → β₂ a) : (f.map (sigma.embedding.mk₂ p)).keys = f.keys :=
finset.val_inj.mp $ by simp

end map_id

end αβ₁β₂

end finmap


lemma main : false :=
begin
have helper : (∃ x : ℕ, true) → false :=
    λ ⟨x, h⟩, by apply _fun_match; assumption,
exact helper ⟨0, ⟨⟩⟩,
end


import logic.equiv.transfer_instance

lemma ring_hom.is_field {R S : Type*} [semifield R] [semiring S] [nontrivial S] (f : R →+* S)
  (hf : function.surjective f) : is_field S :=
begin
  constructor,
  { exact exists_pair_ne _ },
  { intros x y, obtain ⟨x, rfl⟩ := hf x, obtain ⟨y, rfl⟩ := hf y,
    rw [← map_mul, ← map_mul, mul_comm] },
  { intros a ha, obtain ⟨a, rfl⟩ := hf a, use f (1 / a), rw [← map_mul, mul_div_cancel', map_one],
    rintro rfl, apply ha, rw map_zero }
end

lemma ring_equiv.is_field {R S : Type*} [semifield R] [semiring S] (f : R ≃+* S) : is_field S :=
begin
  haveI := f.to_equiv.symm.nontrivial,
  exact f.to_ring_hom.is_field f.surjective
end

lemma ring_equiv.is_field_of_is_field {R S : Type*} [semiring R] [semiring S] (f : R ≃+* S)
  (h : is_field R) : is_field S :=
begin
  letI := h.to_semifield,
  exact f.is_field
end


import for_mathlib.algebraic_topology.homotopical_algebra.cofibrant_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 cofibrant_replacement

def obj (X : C) : cofibrant_object C :=
cofibrant_object.mk (CM5b.obj (initial.to X))

def app (X : C) : (obj X).obj ⟶ X := CM5b.p (initial.to X)

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

instance (X : C) : fibration (app X) := by { dsimp [app], apply_instance, }
instance (X : C) : weak_eq (app X) := by { dsimp [app], apply_instance, }

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

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

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

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

lemma map_eq {X Y : C} (f : X ⟶ Y) (f' : obj X ⟶ obj Y)
  (sq : comm_sq (app X) ((cofibrant_object.forget C).map f') f (app Y)) :
  map f = cofibrant_object.homotopy_category.Q.map f' :=
begin
  apply category_theory.quotient.sound,
  apply cofibrant_object.right_homotopy.trans_closure.mk,
  let Cyl := cylinder.some (obj X).obj,
  suffices : left_homotopy Cyl.pre (map' f) f',
  { exact cofibrant_object.right_homotopy.mk (path_object.some (obj Y).obj)
      (this.to_right_homotopy _), },
  have sq' : comm_sq (coprod.desc ((cofibrant_object.forget C).map (map' f)) f') Cyl.ι
    (app Y) (Cyl.σ ≫ app X ≫ f),
  { refine comm_sq.mk _,
    ext,
    { simpa only [precylinder.ι, cofibrant_object.forget_map, coprod.desc_comp,
        coprod.inl_desc, coprod.desc_comp_assoc, precylinder.σd₀, id_comp] using fac f, },
    { simpa only [precylinder.ι, coprod.desc_comp, coprod.inr_desc, coprod.desc_comp_assoc,
        precylinder.σd₁, id_comp] using sq.w.symm, }, },
  exact
  { h := sq'.lift,
    h₀' := by simpa using congr_arg (λ f, limits.coprod.inl ≫ f) sq'.fac_left,
    h₁' := by simpa using congr_arg (λ f, limits.coprod.inr ≫ f) sq'.fac_left, },
end

end cofibrant_replacement

variable (C)

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

variables {Hocof : Type*} [category Hocof] (Lcof : cofibrant_object C ⥤ Hocof)
  [Lcof.is_localization cofibrant_object.weq]
  {Ho : Type*} [category Ho] (L : C ⥤ Ho) [L.is_localization weq]

namespace cofibrant_replacement

variable {C}

lemma weq_iff {X Y : C} (f : X ⟶ Y) (f' : obj X ⟶ obj Y)
  (sq : comm_sq (app X) ((cofibrant_object.forget C).map f') f (app Y)) :
  weq f ↔ cofibrant_object.weq f' :=
begin
  split,
  { intro hf,
    have h : weq (app X ≫ f) := CM2.of_comp (app X) f weak_eq.property hf,
    rw sq.w at h,
    exact CM2.of_comp_right _ _ weak_eq.property h, },
  { intro hf',
    have h : weq (app X ≫ f),
    { rw sq.w,
      exact CM2.of_comp _ _ hf' weak_eq.property, },
    exact CM2.of_comp_left _ _ weak_eq.property h, },
end

lemma weq_eq_inverse_image_homotopy_category_weq :
  model_category.weq =
cofibrant_object.homotopy_category.weq.inverse_image (cofibrant_replacement C) :=
begin
  ext X Y f,
  dsimp only [morphism_property.inverse_image, cofibrant_replacement, map],
  rw cofibrant_object.homotopy_category.weq_Q_map_iff,
  exact weq_iff _ _ (comm_sq.mk (fac f).symm),
end

include Lcof

@[simps]
def π : cofibrant_object.homotopy_category C ⥤ Hocof :=
category_theory.quotient.lift _ Lcof (λ (X Y : cofibrant_object C), begin
  let Y' : cofibrant_object C := cofibrant_object.mk (CM5a.obj (terminal.from Y.obj)),
  let φ : Y ⟶ Y' := CM5a.i (terminal.from Y.obj),
  intros f₁ f₂ h,
  haveI : is_iso (Lcof.map φ) := localization.inverts Lcof cofibrant_object.weq φ
    (by { change weq (CM5a.i (terminal.from Y.obj)), exact weak_eq.property, }),
  simp only [← cancel_mono (Lcof.map φ), ← Lcof.map_comp],
  induction h with g₁ g₂ h g₁ g₂ g₃ H₁₂ H₂₃ h₁₂ h₂₃,
  { rcases h.comp_right φ with ⟨P, H⟩,
    let Cyl := cylinder.some X.obj,
    let I' := cofibrant_object.mk Cyl.I,
    let s : I' ⟶ X := Cyl.σ,
    haveI : is_iso (Lcof.map s) := localization.inverts Lcof cofibrant_object.weq s
      (by { change weq Cyl.σ, exact weak_eq.property, }),
    let h' := H.some.to_left_homotopy Cyl,
    let ψ : I' ⟶ Y' := h'.h,
    let d₀ : X ⟶ I' := Cyl.d₀,
    let d₁ : X ⟶ I' := Cyl.d₁,
    have eq₀ : d₀ ≫ ψ = g₁ ≫ φ := h'.h₀,
    have eq₁ : d₁ ≫ ψ = g₂ ≫ φ := h'.h₁,
    simp only [← eq₀, ← eq₁, Lcof.map_comp],
    congr' 1,
    simp only [← cancel_mono (Lcof.map s), ← Lcof.map_comp],
    congr' 1,
    exact Cyl.σd₀.trans Cyl.σd₁.symm, },
  { exact h₁₂.trans h₂₃, },
end)

lemma π_inverts_weq : cofibrant_object.homotopy_category.weq.is_inverted_by (π Lcof) := λ X Y f hf,
begin
  rcases cofibrant_object.homotopy_category.Q_map_surjective _ _ f with ⟨g, hg⟩,
  subst hg,
  simp only [cofibrant_object.homotopy_category.Q_map, quotient.functor_map,
    π_map, quot.lift_on_mk],
  apply localization.inverts Lcof cofibrant_object.weq g,
  exact (cofibrant_object.homotopy_category.weq_Q_map_iff g).mp hf,
end

omit Lcof

lemma forget_comp_L_inverts_weq :
  cofibrant_object.weq.is_inverted_by (cofibrant_object.forget C ⋙ L) :=
λ X Y f hf, by convert localization.inverts L weq ((cofibrant_object.forget C).map f) hf

def R : C ⥤ Hocof := cofibrant_replacement C ⋙ π Lcof

lemma R_inverts_weq : weq.is_inverted_by (R Lcof) := λ X Y f hf,
begin
  dsimp only [R, functor.comp_map],
  exact (π_inverts_weq Lcof) _
    (by simpa only [weq_eq_inverse_image_homotopy_category_weq] using hf),
end

def forget_comp_R_iso : cofibrant_object.forget C ⋙ R Lcof ≅ Lcof :=
nat_iso.of_components (λ X, localization.iso_of_hom' Lcof cofibrant_object.weq (app' X)
  (by { dsimp [app'], exact weak_eq.property, }))
(λ X Y f, begin
  simp only [functor.comp_map, cofibrant_object.forget_map, localization.iso_of_hom'_hom],
  rw [← Lcof.map_comp, ← fac' f, Lcof.map_comp],
  refl,
end)

def R_comp_I'_iso {I' : Hocof ⥤ Ho} (sq : Comm_sq (cofibrant_object.forget C) Lcof L I') :
  R Lcof ⋙ I' ≅ L :=
nat_iso.of_components (λ X, sq.iso.app _ ≪≫
  localization.iso_of_hom' L model_category.weq (app X) weak_eq.property)
(λ X Y f, begin
  simp only [functor.comp_map, iso.trans_hom, iso.app_hom, localization.iso_of_hom'_hom, assoc,
    ← L.map_comp],
  simp only [← fac, L.map_comp, ← assoc],
  congr' 1,
  apply sq.iso.hom.naturality,
end)

def is_equivalence (I' : Hocof ⥤ Ho)
  (sq : Comm_sq (cofibrant_object.forget C) Lcof L I') : is_equivalence I' :=
localization.lifting_is_equivalence sq cofibrant_object.weq model_category.weq
  (R Lcof) (localization.lift (R Lcof) (R_inverts_weq Lcof) L)
  (R_comp_I'_iso Lcof L sq) (forget_comp_R_iso Lcof)

end cofibrant_replacement

variable {C}

def Hocof_to_Ho : Hocof ⥤ Ho :=
localization.lift ((cofibrant_object.forget C) ⋙ L)
  (cofibrant_replacement.forget_comp_L_inverts_weq L) Lcof

def Lcof_comp_Hocof_to_Ho_iso : Lcof ⋙ Hocof_to_Ho Lcof L ≅ cofibrant_object.forget C ⋙ L :=
localization.fac _ _ _

instance : is_equivalence (Hocof_to_Ho Lcof L) :=
cofibrant_replacement.is_equivalence Lcof L (Hocof_to_Ho Lcof L)
    ⟨Lcof_comp_Hocof_to_Ho_iso Lcof L⟩

lemma is_iso_Lcof_map' {X Y : cofibrant_object C} (f : X ⟶ Y) (hf : cofibrant_object.weq f) :
  is_iso (Lcof.map f) := localization.inverts Lcof cofibrant_object.weq f hf

lemma is_iso_Lcof_map {X Y : cofibrant_object C} (f : X ⟶ Y)
  [weak_eq ((cofibrant_object.forget C).map f)] : is_iso (Lcof.map f) :=
is_iso_Lcof_map' Lcof f weak_eq.property

end model_category

end algebraic_topology


noncomputable section

theorem ex : ∃ x : Nat, x > 0 :=
  ⟨1, by decide⟩

def a : Nat := Classical.choose ex

def b : Nat := 0

abbrev c : Nat := Classical.choose ex

abbrev d : Nat := 1

instance e : Inhabited Nat :=
 ⟨a⟩

instance f : Inhabited Nat :=
 ⟨b⟩

#eval b + d + f.default

section Foo

def g : Nat := Classical.choose ex

def h (x : Nat) : Nat :=
  match x with
  | 0 => a
  | x+1 => h x + 1

end Foo

end

def i : Nat := Classical.choose ex -- Error


open Lean

def foo : Name := `foo

def isFoo : Name → Bool
  | ``foo => true
  | _     => false

theorem ex1 : isFoo `foo = true  := rfl
theorem ex2 : isFoo `bla = false := rfl

def Bla.boo : Name := `boo

open Bla

def isBoo : Name → Bool
  | ``boo => true
  | _     => false

theorem ex3 : isBoo `Bla.boo = true := rfl
theorem ex4 : isBoo ``boo = true := rfl
theorem ex5 : ``boo = `Bla.boo := rfl


import .admits
import .misc_list

import data.finset

set_option pp.parens true

open formula

inductive is_prop_sub : formula → variable_ → variable_ → formula → Prop
| true_
  (v t : variable_) :
  is_prop_sub true_ v t true_

| pred_
  (name : pred_name_) (args : list variable_)
  (v t : variable_) :
    is_prop_sub (pred_ name args) v t (pred_ name (args.map (fun (x : variable_), if x = v then t else x)))

| eq_
  (x y : variable_)
  (v t : variable_) :
    is_prop_sub (eq_ x y) v t (eq_ (if x = v then t else x) (if y = v then t else y))

| not_
  (P : formula)
  (v t : variable_)
  (P' : formula) :
  is_prop_sub P v t P' →
  is_prop_sub P.not_ v t P'.not_

| imp_
  (P Q : formula)
  (v t : variable_)
  (P' Q' : formula) :
  is_prop_sub P v t P' →
  is_prop_sub Q v t Q' →
  is_prop_sub (P.imp_ Q) v t (P'.imp_ Q')

| forall_same_
  (x : variable_) (P : formula)
  (v t : variable_) :
  v = x →
  is_prop_sub (forall_ x P) v t (forall_ x P)

| forall_diff_nel_
  (x : variable_) (P : formula)
  (v t : variable_)
  (P' : formula) :
  ¬ v = x →
  ¬ is_free_in v (forall_ x P) →
  is_prop_sub P v t P' →
  is_prop_sub (forall_ x P) v t (forall_ x P')

| forall_diff_
  (x : variable_) (P : formula)
  (v t : variable_)
  (P' : formula) :
  ¬ v = x →
  ¬ t = x →
  is_prop_sub P v t P' →
  is_prop_sub (forall_ x P) v t (forall_ x P')

lemma fast_admits_aux_and_fast_replace_free_imp_is_prop_sub
  (P P' : formula)
  (v u : variable_)
  (binders : finset variable_)
  (h1 : fast_admits_aux v u binders P)
  (h2 : fast_replace_free v u P = P') :
  is_prop_sub P v u P' :=
begin
  subst h2,
  induction P generalizing binders,
  case formula.true_ : binders h1
  {
    unfold fast_replace_free,
    apply is_prop_sub.true_,
  },
  case formula.pred_ : name args binders h1
  {
    unfold fast_replace_free,
    apply is_prop_sub.pred_,
  },
  case formula.eq_ : x y binders h1
  {
    unfold fast_replace_free,
    apply is_prop_sub.eq_,
  },
  case formula.not_ : P P_ih binders h1
  {
    unfold fast_admits_aux at h1,

    apply is_prop_sub.not_,
    exact P_ih binders h1,
  },
  case formula.imp_ : P Q P_ih Q_ih binders h1
  {
    unfold fast_admits_aux at h1,
    cases h1,

    apply is_prop_sub.imp_,
    {
      exact P_ih binders h1_left,
    },
    {
      exact Q_ih binders h1_right,
    }
  },
  case formula.forall_ : x P P_ih binders h1
  {
    unfold fast_admits_aux at h1,

    cases h1,
    {
      unfold fast_replace_free,
      split_ifs,
      apply is_prop_sub.forall_same_ x P v u h1,
    },
    {
      unfold fast_replace_free,
      split_ifs,
      {
        apply is_prop_sub.forall_same_ x P v u h,
      },
      {
        by_cases c1 : is_free_in v (forall_ x P),
        {
          apply is_prop_sub.forall_diff_,
          {
            exact h,
          },
          {
            unfold is_free_in at c1,
            cases c1,
            have s1 : u ∉ binders ∪ {x},
            apply fast_admits_aux_is_free_in P v u,
            {
              exact h1,
            },
            {
              exact c1_right,
            },

            simp only [finset.mem_union, finset.mem_singleton] at s1,
            push_neg at s1,
            cases s1,
            exact s1_right,
          },
          {
            apply P_ih (binders ∪ {x}),
            exact h1,
          }
        },
        {
          apply is_prop_sub.forall_diff_nel_,
          {
            exact h,
          },
          {
            exact c1,
          },
          {
            apply P_ih (binders ∪ {x}) h1,
          },
        }
      }
    }
  },
end

lemma is_prop_sub_imp_fast_admits_aux
  (P : formula)
  (v u : variable_)
  (binders : finset variable_)
  (h1 : ∃ (P' : formula), is_prop_sub P v u P')
  (h2 : u ∉ binders) :
  fast_admits_aux v u binders P :=
begin
  apply exists.elim h1,
  intros P' h1_1,
  clear h1,

  induction h1_1 generalizing binders,
  case is_prop_sub.true_ : h1_1_v h1_1_t binders h2
  {
    unfold fast_admits_aux,
  },
  case is_prop_sub.pred_ : h1_1_name h1_1_args h1_1_v h1_1_t binders h2
  {
    unfold fast_admits_aux,
    intros a1,
    exact h2,
  },
  case is_prop_sub.eq_ : h1_1_x h1_1_y h1_1_v h1_1_t binders h2
  {
    unfold fast_admits_aux,
    intros a1,
    exact h2,
  },
  case is_prop_sub.not_ : h1_1_P h1_1_v h1_1_t h1_1_P' h1_1_1 h1_1_ih binders h2
  {
    unfold fast_admits_aux,
    exact h1_1_ih binders h2,
  },
  case is_prop_sub.imp_ : h1_1_P h1_1_Q h1_1_v h1_1_t h1_1_P' h1_1_Q' h1_1_1 h1_1_2 h1_1_ih_1 h1_1_ih_2 binders h2
  {
    unfold fast_admits_aux,
    split,
    {
      exact h1_1_ih_1 binders h2,
    },
    {
      exact h1_1_ih_2 binders h2,
    }
  },
  case is_prop_sub.forall_same_ : h1_1_x h1_1_P h1_1_v h1_1_t h1_1_1 binders h2
  {
    unfold fast_admits_aux,
    apply or.intro_left,
    exact h1_1_1,
  },
  case is_prop_sub.forall_diff_nel_ : h1_1_x h1_1_P h1_1_v h1_1_t h1_1_P' h1_1_1 h1_1_2 h1_1_3 h1_1_ih binders h2
  {
    unfold is_free_in at h1_1_2,
    push_neg at h1_1_2,

    unfold fast_admits_aux,

    apply or.intro_right,
    apply not_is_free_in_imp_fast_admits_aux,
    apply h1_1_2,
    exact h1_1_1,
  },
  case is_prop_sub.forall_diff_ : h1_1_x h1_1_P h1_1_v h1_1_t h1_1_P' h1_1_1 h1_1_2 h1_1_3 h1_1_ih binders h2
  {
    unfold fast_admits_aux,
    apply or.intro_right,
    apply h1_1_ih,
    simp only [finset.mem_union, finset.mem_singleton],
    push_neg,
    split,
    {
      exact h2,
    },
    {
      exact h1_1_2,
    }
  },
end

lemma is_prop_sub_imp_fast_replace_free
  (P P' : formula)
  (v u : variable_)
  (h1 : is_prop_sub P v u P') :
  fast_replace_free v u P = P' :=
begin
  induction h1,
  case is_prop_sub.true_ : h1_v h1_t
  {
    refl,
  },
  case is_prop_sub.pred_ : h1_name h1_args h1_v h1_t
  {
    unfold fast_replace_free,
  },
  case is_prop_sub.eq_ : h1_x h1_y h1_v h1_t
  {
    unfold fast_replace_free,
  },
  case is_prop_sub.not_ : h1_P h1_v h1_t h1_P' h1_1 h1_ih
  {
    unfold fast_replace_free,
    congr,
    exact h1_ih,
  },
  case is_prop_sub.imp_ : h1_P h1_Q h1_v h1_t h1_P' h1_Q' h1_1 h1_2 h1_ih_1 h1_ih_2
  {
    unfold fast_replace_free,
    congr,
    {
      exact h1_ih_1,
    },
    {
      exact h1_ih_2,
    }
  },
  case is_prop_sub.forall_same_ : h1_x h1_P h1_v h1_t h1_1
  {
    apply not_free_in_fast_replace_free_id,
    unfold is_free_in,
    simp only [finset.mem_sdiff, finset.mem_singleton, not_and, not_not],
    intros a1,
    contradiction,
  },
  case is_prop_sub.forall_diff_nel_ : h1_x h1_P h1_v h1_t h1_P' h1_1 h1_2 h1_3 h1_ih
  {
    unfold fast_replace_free,
    split_ifs,
    simp only [eq_self_iff_true, true_and],
    apply h1_ih,
  },
  case is_prop_sub.forall_diff_ : h1_x h1_P h1_v h1_t h1_P' h1_1 h1_2 h1_3 h1_ih
  {
    unfold fast_replace_free,
    split_ifs,
    simp only [eq_self_iff_true, true_and],
    apply h1_ih,
  },
end

example
  (P P' : formula)
  (v u : variable_) :
  is_prop_sub P v u P' ↔
    (fast_admits v u P ∧ fast_replace_free v u P = P') :=
begin
  unfold fast_admits,
  split,
  {
    intros a1,
    split,
    {
      apply is_prop_sub_imp_fast_admits_aux,
      {
        apply exists.intro P',
        exact a1,
      },
      {
        simp only [finset.not_mem_empty, not_false_iff],
      }
    },
    {
      apply is_prop_sub_imp_fast_replace_free,
      exact a1,
    }
  },
  {
    intros a1,
    cases a1,
    exact fast_admits_aux_and_fast_replace_free_imp_is_prop_sub P P' v u ∅ a1_left a1_right,
  }
end


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

import AesopTest.Persistence0

namespace Aesop

@[aesop 50% constructors (rule_sets [test_persistence1])]
inductive NatOrBool where
  | ofNat (n : Nat)
  | ofBool (b : Bool)

example (b : Bool) : NatOrBool := by
  aesop (rule_sets [test_persistence1])

end Aesop


open classical
variables (α : Type) (p q : α -> Prop)
variable a : α
variable r : Prop
example : r → (∃ x : α, r) :=
assume (h1 : r),
show ∃ x : α, r, from exists.intro a h1


/-
Copyright (c) 2021 Rémy Degenne. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Rémy Degenne

! This file was ported from Lean 3 source module measure_theory.tactic
! leanprover-community/mathlib commit d003c55042c3cd08aefd1ae9a42ef89441cdaaf3
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.MeasureTheory.Measure.MeasureSpaceDef
import Mathbin.Tactic.AutoCases
import Mathbin.Tactic.Tidy
import Mathbin.Tactic.WithLocalReducibility

/-!
# Tactics for measure theory

Currently we have one domain-specific tactic for measure theory: `measurability`.

This tactic is to a large extent a copy of the `continuity` tactic by Reid Barton.
-/

/-!
### `measurability` tactic

Automatically solve goals of the form `measurable f`, `ae_measurable f μ` and `measurable_set s`.

Mark lemmas with `@[measurability]` to add them to the set of lemmas
used by `measurability`. Note: `to_additive` doesn't know yet how to
copy the attribute to the additive version.
-/

/-- User attribute used to mark tactics used by `measurability`. -/
@[user_attribute]
unsafe def measurability : user_attribute
    where
  Name := `measurability
  descr := "lemmas usable to prove (ae)-measurability"
#align measurability measurability

/- Mark some measurability lemmas already defined in `measure_theory.measurable_space_def` and
`measure_theory.measure_space_def` -/
attribute [measurability]
  measurable_id measurable_id' aeMeasurableId aeMeasurableId' measurable_const aeMeasurableConst AeMeasurable.measurable_mk MeasurableSet.empty MeasurableSet.univ MeasurableSet.compl Subsingleton.measurableSet MeasurableSet.unionᵢ MeasurableSet.interᵢ MeasurableSet.union MeasurableSet.inter MeasurableSet.diff MeasurableSet.symmDiff MeasurableSet.ite MeasurableSet.cond MeasurableSet.disjointed MeasurableSet.const MeasurableSet.insert measurableSet_eq Finset.measurableSet MeasurableSpace.measurableSet_top

namespace Tactic

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/-- Tactic to apply `measurable.comp` when appropriate.

Applying `measurable.comp` is not always a good idea, so we have some
extra logic here to try to avoid bad cases.

* If the function we're trying to prove measurable is actually
  constant, and that constant is a function application `f z`, then
  measurable.comp would produce new goals `measurable f`, `measurable
  (λ _, z)`, which is silly. We avoid this by failing if we could
  apply `measurable_const`.

* measurable.comp will always succeed on `measurable (λ x, f x)` and
  produce new goals `measurable (λ x, x)`, `measurable f`. We detect
  this by failing if a new goal can be closed by applying
  measurable_id.
-/
unsafe def apply_measurable.comp : tactic Unit :=
  sorry
#align tactic.apply_measurable.comp tactic.apply_measurable.comp

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/-- Tactic to apply `measurable.comp_ae_measurable` when appropriate.

Applying `measurable.comp_ae_measurable` is not always a good idea, so we have some
extra logic here to try to avoid bad cases.

* If the function we're trying to prove measurable is actually
  constant, and that constant is a function application `f z`, then
  `measurable.comp_ae_measurable` would produce new goals `measurable f`, `ae_measurable
  (λ _, z) μ`, which is silly. We avoid this by failing if we could
  apply `ae_measurable_const`.

* `measurable.comp_ae_measurable` will always succeed on `ae_measurable (λ x, f x) μ` and
  can produce new goals (`measurable (λ x, x)`, `ae_measurable f μ`) or
  (`measurable f`, `ae_measurable (λ x, x) μ`). We detect those by failing if a new goal can be
  closed by applying `measurable_id` or `ae_measurable_id`.
-/
unsafe def apply_measurable.comp_ae_measurable : tactic Unit :=
  sorry
#align tactic.apply_measurable.comp_ae_measurable tactic.apply_measurable.comp_ae_measurable

/--
We don't want the intro1 tactic to apply to a goal of the form `measurable f`, `ae_measurable f μ`
or `measurable_set s`. This tactic tests the target to see if it matches that form.
 -/
unsafe def goal_is_not_measurable : tactic Unit := do
  let t ← tactic.target
  match t with
    | q(Measurable $(l)) => failed
    | q(AeMeasurable $(l) $(r)) => failed
    | q(MeasurableSet $(l)) => failed
    | _ => skip
#align tactic.goal_is_not_measurable tactic.goal_is_not_measurable

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/-- List of tactics used by `measurability` internally. The option `use_exfalso := ff` is passed to
the tactic `apply_assumption` in order to avoid loops in the presence of negated hypotheses in
the context. -/
unsafe def measurability_tactics (md : Transparency := semireducible) : List (tactic String) :=
  [(propositional_goal >> tactic.interactive.apply_assumption none { use_exfalso := false }) >>
      pure "apply_assumption {use_exfalso := ff}",
    goal_is_not_measurable >> intro1 >>= fun ns => pure ("intro " ++ ns.toString),
    apply_rules [] [`` measurability] 50 { md } >> pure "apply_rules with measurability",
    apply_measurable.comp >> pure "refine measurable.comp _ _",
    apply_measurable.comp_ae_measurable >> pure "refine measurable.comp_ae_measurable _ _",
    sorry >> pure "refine measurable.ae_measurable _",
    sorry >> pure "refine measurable.ae_strongly_measurable _"]
#align tactic.measurability_tactics tactic.measurability_tactics

namespace Interactive

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
/-- Solve goals of the form `measurable f`, `ae_measurable f μ`, `ae_strongly_measurable f μ` or
`measurable_set s`. `measurability?` reports back the proof term it found.
-/
unsafe def measurability (bang : parse <| optional (tk "!")) (trace : parse <| optional (tk "?"))
    (cfg : tidy.cfg := { }) : tactic Unit :=
  let md := if bang.isSome then semireducible else reducible
  let measurability_core := tactic.tidy { cfg with tactics := measurability_tactics md }
  let trace_fn := if trace.isSome then show_term else id
  trace_fn measurability_core
#align tactic.interactive.measurability tactic.interactive.measurability

/-- Version of `measurability` for use with auto_param. -/
unsafe def measurability' : tactic Unit :=
  measurability none none { }
#align tactic.interactive.measurability' tactic.interactive.measurability'

/-- `measurability` solves goals of the form `measurable f`, `ae_measurable f μ`,
`ae_strongly_measurable f μ` or `measurable_set s` by applying lemmas tagged with the
`measurability` user attribute.

You can also use `measurability!`, which applies lemmas with `{ md := semireducible }`.
The default behaviour is more conservative, and only unfolds `reducible` definitions
when attempting to match lemmas with the goal.

`measurability?` reports back the proof term it found.
-/
add_tactic_doc
  { Name := "measurability / measurability'"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.measurability, `tactic.interactive.measurability']
    tags := ["lemma application"] }

end Interactive

end Tactic


import tactic.split_ifs

example (p : Prop) [decidable p] (h : (if p then 1 else 2) > 3) : false :=
by split_ifs at h; repeat {cases h with h h}

example (p : Prop) [decidable p] (x : ℕ) (h : (if p then 1 else 2) > x) :
    x < (if ¬p then 1 else 0) + 1 :=
by split_ifs at *; assumption

example (p : Prop) [decidable p] : if if ¬p then p else true then p else ¬p :=
by split_ifs; assumption

example (p q : Prop) [decidable p] [decidable q] :
    if if if p then ¬p else q then p else q then q else ¬p ∨ ¬q :=
by split_ifs; simp *

example : true :=
by success_if_fail { split_ifs }; trivial


-- Copyright (c) 2017 Scott Morrison. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.
-- Authors: Tim Baumann, Stephen Morgan, Scott Morrison

import category_theory.fully_faithful
import category_theory.functor_category
import category_theory.natural_isomorphism
import tactic.slice
import tactic.converter.interactive

namespace category_theory

universes v₁ v₂ v₃ u₁ u₂ u₃ -- declare the `v`'s first; see `category_theory.category` for an explanation

structure equivalence (C : Type u₁) [category.{v₁} C] (D : Type u₂) [category.{v₂} D] :=
(functor : C ⥤ D)
(inverse : D ⥤ C)
(fun_inv_id' : (functor ⋙ inverse) ≅ (category_theory.functor.id C) . obviously)
(inv_fun_id' : (inverse ⋙ functor) ≅ (category_theory.functor.id D) . obviously)

restate_axiom equivalence.fun_inv_id'
restate_axiom equivalence.inv_fun_id'

infixr ` ≌ `:10  := equivalence

namespace equivalence

variables {C : Type u₁} [𝒞 : category.{v₁} C]
include 𝒞

@[refl] def refl : C ≌ C :=
{ functor := functor.id C,
  inverse := functor.id C }

variables {D : Type u₂} [𝒟 : category.{v₂} D]
include 𝒟

@[symm] def symm (e : C ≌ D) : D ≌ C :=
{ functor := e.inverse,
  inverse := e.functor,
  fun_inv_id' := e.inv_fun_id,
  inv_fun_id' := e.fun_inv_id }

@[simp] lemma fun_inv_map (e : C ≌ D) (X Y : D) (f : X ⟶ Y) :
e.functor.map (e.inverse.map f) = (e.inv_fun_id.hom.app X) ≫ f ≫ (e.inv_fun_id.inv.app Y) :=
begin
  erw [nat_iso.naturality_2],
  refl
end
@[simp] lemma inv_fun_map (e : C ≌ D) (X Y : C) (f : X ⟶ Y) :
e.inverse.map (e.functor.map f) = (e.fun_inv_id.hom.app X) ≫ f ≫ (e.fun_inv_id.inv.app Y) :=
begin
  erw [nat_iso.naturality_2],
  refl
end

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

@[simp] private def effe_iso_id (e : C ≌ D) (f : D ≌ E) (X : C) :
  (e.inverse).obj ((f.inverse).obj ((f.functor).obj ((e.functor).obj X))) ≅ X :=
calc
  (e.inverse).obj ((f.inverse).obj ((f.functor).obj ((e.functor).obj X)))
    ≅ (e.inverse).obj ((e.functor).obj X) : e.inverse.on_iso (nat_iso.app f.fun_inv_id _)
... ≅ X                                   : nat_iso.app e.fun_inv_id _

@[simp] private def feef_iso_id (e : C ≌ D) (f : D ≌ E) (X : E) :
  (f.functor).obj ((e.functor).obj ((e.inverse).obj ((f.inverse).obj X))) ≅ X :=
calc
  (f.functor).obj ((e.functor).obj ((e.inverse).obj ((f.inverse).obj X)))
    ≅ (f.functor).obj ((f.inverse).obj X) : f.functor.on_iso (nat_iso.app e.inv_fun_id _)
... ≅ X                                   : nat_iso.app f.inv_fun_id _

@[trans] def trans (e : C ≌ D) (f : D ≌ E) : C ≌ E :=
{ functor := e.functor ⋙ f.functor,
  inverse := f.inverse ⋙ e.inverse,
  fun_inv_id' := nat_iso.of_components (effe_iso_id e f)
  begin
    /- `tidy` says -/
    intros X Y f_1, dsimp at *, simp at *, dsimp at *,
    /- `rewrite_search` says -/
    slice_lhs 3 4 { erw [is_iso.hom_inv_id] },
    erw [category.id_comp, is_iso.hom_inv_id, category.comp_id],
  end,
  inv_fun_id' := nat_iso.of_components (feef_iso_id e f)
  begin
    /- `tidy` says -/
    intros X Y f_1, dsimp at *, simp at *, dsimp at *,
    /- `rewrite_search` says -/
    slice_lhs 3 4 { erw [is_iso.hom_inv_id] },
    erw [category.id_comp, is_iso.hom_inv_id, category.comp_id]
  end
}

end equivalence

variables {C : Type u₁} [𝒞 : category.{v₁} C]
include 𝒞

section
variables {D : Type u₂} [𝒟 : category.{v₂} D]
include 𝒟

class is_equivalence (F : C ⥤ D) :=
(inverse        : D ⥤ C)
(fun_inv_id' : (F ⋙ inverse) ≅ (functor.id C) . obviously)
(inv_fun_id' : (inverse ⋙ F) ≅ (functor.id D) . obviously)

restate_axiom is_equivalence.fun_inv_id'
restate_axiom is_equivalence.inv_fun_id'
end

namespace is_equivalence
variables {D : Type u₂} [𝒟 : category.{v₂} D]
include 𝒟

instance of_equivalence (F : C ≌ D) : is_equivalence (F.functor) :=
{ inverse := F.inverse,
  fun_inv_id' := F.fun_inv_id,
  inv_fun_id' := F.inv_fun_id }
instance of_equivalence_inverse (F : C ≌ D) : is_equivalence (F.inverse) :=
{ inverse := F.functor,
  fun_inv_id' := F.inv_fun_id,
  inv_fun_id' := F.fun_inv_id }
end is_equivalence

namespace functor
instance is_equivalence_refl : is_equivalence (functor.id C) :=
{ inverse := functor.id C }
end functor

variables {D : Type u₂} [𝒟 : category.{v₂} D]
include 𝒟

namespace functor
def inv (F : C ⥤ D) [is_equivalence F] : D ⥤ C :=
is_equivalence.inverse F

instance is_equivalence_symm (F : C ⥤ D) [is_equivalence F] : is_equivalence (F.inv) :=
{ inverse := F,
  fun_inv_id' := is_equivalence.inv_fun_id F,
  inv_fun_id' := is_equivalence.fun_inv_id F }

def fun_inv_id (F : C ⥤ D) [is_equivalence F] : (F ⋙ F.inv) ≅ functor.id C :=
is_equivalence.fun_inv_id F

def inv_fun_id (F : C ⥤ D) [is_equivalence F] : (F.inv ⋙ F) ≅ functor.id D :=
is_equivalence.inv_fun_id F

def as_equivalence (F : C ⥤ D) [is_equivalence F] : C ≌ D :=
{ functor := F,
  inverse := is_equivalence.inverse F,
  fun_inv_id' := is_equivalence.fun_inv_id F,
  inv_fun_id' := is_equivalence.inv_fun_id F }

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

instance is_equivalence_trans (F : C ⥤ D) (G : D ⥤ E) [is_equivalence F] [is_equivalence G] :
  is_equivalence (F ⋙ G) :=
is_equivalence.of_equivalence (equivalence.trans (as_equivalence F) (as_equivalence G))

end functor

namespace is_equivalence
instance is_equivalence_functor (e : C ≌ D) : is_equivalence e.functor :=
{ inverse := e.inverse,
  fun_inv_id' := e.fun_inv_id,
  inv_fun_id' := e.inv_fun_id }
instance is_equivalence_inverse (e : C ≌ D) : is_equivalence e.inverse :=
{ inverse := e.functor,
  fun_inv_id' := e.inv_fun_id,
  inv_fun_id' := e.fun_inv_id }

@[simp] lemma fun_inv_map (F : C ⥤ D) [is_equivalence F] (X Y : D) (f : X ⟶ Y) :
  F.map (F.inv.map f) = (F.inv_fun_id.hom.app X) ≫ f ≫ (F.inv_fun_id.inv.app Y) :=
begin
  erw [nat_iso.naturality_2],
  refl
end
@[simp] lemma inv_fun_map (F : C ⥤ D) [is_equivalence F] (X Y : C) (f : X ⟶ Y) :
  F.inv.map (F.map f) = (F.fun_inv_id.hom.app X) ≫ f ≫ (F.fun_inv_id.inv.app Y) :=
begin
  erw [nat_iso.naturality_2],
  refl
end

end is_equivalence

class ess_surj (F : C ⥤ D) :=
(obj_preimage (d : D) : C)
(iso' (d : D) : F.obj (obj_preimage d) ≅ d . obviously)

restate_axiom ess_surj.iso'

namespace functor
def obj_preimage (F : C ⥤ D) [ess_surj F] (d : D) : C := ess_surj.obj_preimage.{v₁ v₂} F d
def fun_obj_preimage_iso (F : C ⥤ D) [ess_surj F] (d : D) : F.obj (F.obj_preimage d) ≅ d :=
ess_surj.iso F d
end functor

namespace equivalence

def ess_surj_of_equivalence (F : C ⥤ D) [is_equivalence F] : ess_surj F :=
⟨ λ Y : D, F.inv.obj Y, λ Y : D, (nat_iso.app F.inv_fun_id Y) ⟩

instance faithful_of_equivalence (F : C ⥤ D) [is_equivalence F] : faithful F :=
{ injectivity' := λ X Y f g w,
  begin
    have p := congr_arg (@category_theory.functor.map _ _ _ _ F.inv _ _) w,
    simp at *,
    assumption
  end }.

instance full_of_equivalence (F : C ⥤ D) [is_equivalence F] : full F :=
{ preimage := λ X Y f, (nat_iso.app F.fun_inv_id X).inv ≫ (F.inv.map f) ≫ (nat_iso.app F.fun_inv_id Y).hom,
  witness' := λ X Y f,
  begin
    apply F.inv.injectivity,
    /- obviously can finish from here... -/
    dsimp, simp, dsimp,
    slice_lhs 4 6 {
      rw [←functor.map_comp, ←functor.map_comp],
      rw [←is_equivalence.fun_inv_map],
    },
    slice_lhs 1 2 { simp },
    dsimp, simp,
    slice_lhs 2 4 {
      rw [←functor.map_comp, ←functor.map_comp],
      erw [nat_iso.naturality_2],
    },
    erw [nat_iso.naturality_1],
    refl,
  end }.

section

@[simp] private def equivalence_inverse (F : C ⥤ D) [full F] [faithful F] [ess_surj F] : D ⥤ C :=
{ obj  := λ X, F.obj_preimage X,
  map := λ X Y f, F.preimage ((F.fun_obj_preimage_iso X).hom ≫ f ≫ (F.fun_obj_preimage_iso Y).inv),
  map_id' := λ X, begin apply F.injectivity, tidy, end,
  map_comp' := λ X Y Z f g, by apply F.injectivity; simp }.

def equivalence_of_fully_faithfully_ess_surj
  (F : C ⥤ D) [full F] [faithful : faithful F] [ess_surj F] : is_equivalence F :=
{ inverse := equivalence_inverse F,
  fun_inv_id' := nat_iso.of_components
    (λ X, preimage_iso (F.fun_obj_preimage_iso (F.obj X)))
    (λ X Y f, begin apply F.injectivity, obviously, end),
  inv_fun_id' := nat_iso.of_components
    (λ Y, (F.fun_obj_preimage_iso Y))
    (by obviously) }
end

end equivalence

end category_theory


import topology.constructions
import topology.separation
import topology.category.Top.basic
import topology.homotopy.basic
import analysis.convex.star

lemma quotient_map_of_is_closed_map {α β} [topological_space α] [topological_space β]
  (f : α → β) : function.surjective f → is_closed_map f → continuous f → quotient_map f :=

begin
  intros hS hC hCont,
  rw quotient_map_iff,
  split, assumption,
  intro U,
  rw [← is_closed_compl_iff, ← is_closed_compl_iff, ← set.preimage_compl],
  generalize : Uᶜ = C,
end


import tactic

universes u v

namespace monad

@[simp]
lemma bind_pure_star {m} [monad m] [is_lawful_monad m] (x : m punit) :
  x >>= (λ (_x : punit), pure punit.star : punit → m punit) = x :=
by { transitivity,
     { apply congr_arg, ext z, cases z, refl },
     { simp } }

variables {α β γ : Type u}
variables {m : Type u → Type v} [monad m]

@[reducible]
def pipe (a : α → m β) (b : β → m γ) : α → m γ :=
λ x, a x >>= b

infixr ` >=> `:55 := pipe

@[functor_norm]
lemma map_bind_eq_bind_comp {α β γ} {m} [monad m] [is_lawful_monad m]
  (f : α → β) (cmd : m α) (g : β → m γ) :
  (f <$> cmd) >>= g = cmd >>= g ∘ f :=
by rw [← bind_pure_comp_eq_map,bind_assoc,(∘)]; simp

@[functor_norm]
lemma bind_map {α β γ} {m} [monad m] [is_lawful_monad m]
  (f : α → γ → β) (cmd : m α) (g : α → m γ) :
  cmd >>= (λ x, f x <$> g x) = do { x ← cmd, y ← g x, pure $ f x y }  :=
by congr; ext; rw [← bind_pure (g x),map_bind]; simp

@[functor_norm]
lemma bind_seq {α β γ : Type u} {m} [monad m] [is_lawful_monad m]
  (f : α → m (γ → β)) (cmd : m α) (g : α → m γ) :
  cmd >>= (λ x, f x <*> g x) = do { x ← cmd, h ← f x, y ← g x, pure $ h y }  :=
by congr; ext; simp [seq_eq_bind_map] with functor_norm

end monad

attribute [functor_norm] bind_assoc has_bind.and_then map_bind


import .nnf .predicates

variables {α β : Type}

def lift_nnf_qe (β) [Hα : atom_type α β] (qe : fm α → fm α) : fm α → fm α
| (p ∧' q) := and_o (lift_nnf_qe p) (lift_nnf_qe q)
| (p ∨' q) := or_o  (lift_nnf_qe p) (lift_nnf_qe q)
| (¬' p) := not_o (lift_nnf_qe p)
| (∃' p) := qe (@nnf α β Hα (lift_nnf_qe p))
| p := p

lemma and_o_prsv_qfree (p q : fm α) :
  qfree p → qfree q → qfree (and_o p q) :=
λ Hp Hq,
  begin
    cases p; cases q;
    {trivial <|> apply Hp <|> apply Hq <|> {apply (and.intro Hp Hq)}}
  end

lemma or_o_prsv_qfree (p q : fm α) :
  qfree p → qfree q → qfree (or_o p q) :=
λ Hp Hq,
  begin
    cases p; cases q;
    {trivial <|> apply Hp <|> apply Hq <|> {apply (and.intro Hp Hq)}}
  end

lemma not_o_prsv_qfree (p : fm α) (H : qfree p) : qfree (not_o p) :=
begin cases p; {trivial <|> apply H} end

lemma lnq_qfree [Hα : atom_type α β] (qe : fm α → fm α)
(H : ∀ (f : fm α), nqfree f → qfree (qe f)) :
  ∀ (f : fm α), qfree (@lift_nnf_qe α β Hα qe f) :=
λ f, fm.rec_on f trivial trivial
  (λ a, trivial)
  (λ f1 f2 H1 H2, and_o_prsv_qfree _ _ H1 H2)
  (λ f1 f2 H1 H2, or_o_prsv_qfree _ _ H1 H2)
  (λ f1 H1, not_o_prsv_qfree _ H1)
  (λ f1 H1, begin apply H, apply nnf_nqfree, apply H1 end)

open tactic

lemma lnq_prsv_gen
  [Hα : atom_type α β] (qe : fm α → fm α)
  (hqe : qfree_res_of_nqfree_arg qe)
  (r : fm α → Prop)
  (hdc : down_closed r)
  (hqc : preserves qe r)
  (hnc : preserves (nnf β) r)
  (hlc : ∀ f, preserves f r → preserves (lift_nnf_qe β f) r)
  (hi : ∀ (p : fm α), nqfree p → r p → ∀ (xs : list β), I (qe p) xs ↔ ∃ x, I p (x::xs)) :
  ∀ (p : fm α), r p → ∀ (xs : list β), I (lift_nnf_qe β qe p) xs ↔ I p xs
| ⊤' _ bs := iff.refl _
| ⊥' _ bs := iff.refl _
| (A' a) _ bs := iff.refl _
| (p ∧' q) hr xs :=
  begin
    unfold lift_nnf_qe, rewrite exp_I_and,
    rewrite exp_I_and_o,
    repeat {rewrite lnq_prsv_gen},
    apply hdc _ _ (down.andr _ _) hr,
    apply hdc _ _ (down.andl _ _) hr
  end
| (p ∨' q) hr xs :=
  begin
    unfold lift_nnf_qe, rewrite exp_I_or,
    rewrite exp_I_or_o, repeat {rewrite lnq_prsv_gen},
    apply hdc _ _ (down.orr _ _) hr,
    apply hdc _ _ (down.orl _ _) hr
  end
| (¬' p) hr xs :=
  begin
    unfold lift_nnf_qe, rewrite exp_I_not,
    rewrite exp_I_not_o, repeat {rewrite lnq_prsv_gen},
    apply hdc _ _ (down.not _) hr
  end
| (∃' p) hr xs :=
  begin
    unfold lift_nnf_qe, rewrite exp_I_ex,
    rewrite hi, apply ex_iff_ex, intro b,
    rewrite nnf_prsv, apply lnq_prsv_gen,
    apply hdc _ _ (down.ex _) hr,
    apply lnq_qfree, apply hqe,
    apply nnf_nqfree, apply lnq_qfree,
    apply hqe, apply hnc, apply hlc, apply hqc,
    apply hdc _ _ (down.ex _) hr
  end

lemma lnq_prsv [Hα : atom_type α β] (qe : fm α → fm α)
  (hqe : qfree_res_of_nqfree_arg qe)
  (hi : ∀ (p : fm α), nqfree p → ∀ (xs : list β), I (qe p) xs ↔ ∃ x, I p (x::xs)) :
  ∀ (p : fm α) (xs : list β), I (lift_nnf_qe β qe p) xs ↔ I p xs :=
begin
  intro p, apply (lnq_prsv_gen _ _ (λ _, true)),
  intros _ _ _ _, trivial,
  intros _ _,  trivial,
  intros _ _,  trivial,
  intros _ _ _ _, trivial,
  intros q hf h', apply hi,
  apply hf, trivial, apply hqe
end


import for_mathlib.homological_complex_abelian
import category_theory.limits.preserves.finite
import category_theory.limits.preserves.shapes.kernels
import for_mathlib.homology

.

open category_theory category_theory.limits

universes v u₁ u₂

variables {C : Type u₁} [category.{v} C] [abelian C]
variables {D : Type u₂} [category.{v} D] [abelian D] (F : C ⥤ D)
variables [preserves_finite_limits F] [preserves_finite_colimits F] [functor.additive F]
variables {ι : Type*} {c : complex_shape ι}

@[simps] noncomputable
def category_theory.limits.cokernel.map_arrow_iso {C : Type u₁} [category.{v} C]
  [has_zero_morphisms C] {X₁ Y₁ X₂ Y₂ : C}
  (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) [has_cokernel f₁] [has_cokernel f₂]
  (e : arrow.mk f₁ ≅ arrow.mk f₂) : cokernel f₁ ≅ cokernel f₂ :=
{ hom := cokernel.map _ _ e.hom.left e.hom.right e.hom.w.symm,
  inv := cokernel.map _ _ e.inv.left e.inv.right e.inv.w.symm,
  hom_inv_id' := begin
    ext,
    simp only [category.comp_id, cokernel.π_desc, cokernel.π_desc_assoc,
      category.assoc, coequalizer_as_cokernel],
    rw [← category.assoc, ← comma.comp_right, e.hom_inv_id, arrow.id_right],
    exact category.id_comp _
  end,
  inv_hom_id' := begin
    ext,
    simp only [category.comp_id, cokernel.π_desc, cokernel.π_desc_assoc,
      category.assoc, coequalizer_as_cokernel],
    rw [← category.assoc, ← comma.comp_right, e.inv_hom_id, arrow.id_right],
    exact category.id_comp _
  end }

@[simps] noncomputable
def category_theory.limits.kernel.map_arrow_iso {C : Type u₁} [category.{v} C]
  [has_zero_morphisms C] {X₁ Y₁ X₂ Y₂ : C}
  (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) [has_kernel f₁] [has_kernel f₂]
  (e : arrow.mk f₁ ≅ arrow.mk f₂) : kernel f₁ ≅ kernel f₂ :=
{ hom := kernel.map _ _ e.hom.left e.hom.right e.hom.w.symm,
  inv := kernel.map _ _ e.inv.left e.inv.right e.inv.w.symm,
  hom_inv_id' := begin
    ext,
    simp only [category.id_comp, kernel.lift_ι, kernel.lift_ι_assoc,
      category.assoc, equalizer_as_kernel],
    rw [← comma.comp_left, e.hom_inv_id, arrow.id_left],
    exact category.comp_id _
  end,
  inv_hom_id' := begin
    ext,
    simp only [category.id_comp, kernel.lift_ι, kernel.lift_ι_assoc,
      category.assoc, equalizer_as_kernel],
    rw [← comma.comp_left, e.inv_hom_id, arrow.id_left],
    exact category.comp_id _
  end }

noncomputable
def category_theory.functor.map_homological_complex_X_prev (F : C ⥤ D) [F.additive]
  (X : homological_complex C c) (i : ι) :
  ((F.map_homological_complex c).obj X).X_prev i ≅ F.obj (X.X_prev i) :=
iso.refl _

lemma category_theory.functor.map_homological_complex_X_prev_eq (F : C ⥤ D) [F.additive]
  (X : homological_complex C c) {i : ι} :
  F.map_homological_complex_X_prev X i = iso.refl _ := rfl

noncomputable
def category_theory.functor.map_homological_complex_X_next (F : C ⥤ D) [F.additive]
  (X : homological_complex C c) (i : ι) :
  ((F.map_homological_complex c).obj X).X_next i ≅ F.obj (X.X_next i) :=
iso.refl _

lemma category_theory.functor.map_homological_complex_X_next_eq (F : C ⥤ D) [F.additive]
  (X : homological_complex C c) {i : ι} :
  F.map_homological_complex_X_next X i = iso.refl _ := rfl

lemma category_theory.functor.map_homological_complex_d_from (F : C ⥤ D) [F.additive]
  (X : homological_complex C c) (i : ι) :
  ((F.map_homological_complex c).obj X).d_from i = F.map (X.d_from i) := rfl

lemma category_theory.functor.map_homological_complex_d_to (F : C ⥤ D) [F.additive]
  (X : homological_complex C c) (i : ι) :
  ((F.map_homological_complex c).obj X).d_to i = F.map (X.d_to i) := rfl

@[simp, reassoc]
lemma category_theory.limits.preserves_kernel_iso_inv_map (F : C ⥤ D)
  [F.additive] [preserves_finite_limits F]
  {X₁ Y₁ X₂ Y₂ : C} (f₁ : X₁ ⟶ Y₁) (f₂ : X₂ ⟶ Y₂) (iX : X₁ ⟶ X₂) (iY : Y₁ ⟶ Y₂) (e) :
  (preserves_kernel.iso F f₁).inv ≫ F.map (kernel.map _ _ iX iY e) =
    kernel.map _ _ (F.map iX) (F.map iY) (by simp_rw [← F.map_comp, e]) ≫
      (preserves_kernel.iso F f₂).inv :=
begin
  rw [iso.eq_comp_inv, category.assoc, eq_comm, iso.eq_inv_comp],
  ext,
  simp,
end
-- attribute [reassoc] kernel.lift_map

open category_theory category_theory.limits

@[simp, reassoc]
lemma homology.π'_iso_cokernel_lift_hom {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (w : f ≫ g = 0) :
  homology.π' f g w ≫ (homology_iso_cokernel_lift f g w).hom = cokernel.π _ :=
begin
  delta homology.π', simp,
end

@[reassoc]
lemma homology.π'_iso_cokernel_lift_inv {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) (w : f ≫ g = 0) :
  cokernel.π _ ≫ (homology_iso_cokernel_lift f g w).inv = homology.π' f g w := rfl

noncomputable
def preserves_homology_of_exact (i : ι) :
  F.map_homological_complex c ⋙ homology_functor _ c i ≅ homology_functor _ c i ⋙ F :=
begin
  fapply nat_iso.of_components,
  { intro X,
    refine homology_iso_cokernel_lift _ _ _ ≪≫
      cokernel.map_arrow_iso _ _ (arrow.iso_mk _ _ _) ≪≫
      (preserves_cokernel.iso _ _).symm ≪≫ F.map_iso (homology_iso_cokernel_lift _ _ _).symm,
    { exact iso.refl _ },
    { refine kernel.map_arrow_iso _ _ (arrow.iso_mk _ _ _) ≪≫ (preserves_kernel.iso _ _).symm,
      { exact iso.refl _ },
      { exact iso.refl _ },
      { dsimp, rw [category.id_comp, F.map_homological_complex_d_from, category.comp_id] } },
    { dsimp, rw [← category.assoc, iso.eq_comp_inv], ext, simp [F.map_homological_complex_d_to] } },
  { intros X Y f, apply homology.hom_from_ext,
    simp only [category_theory.limits.kernel.map_arrow_iso_hom,
      category_theory.functor.map_iso_inv,
      category_theory.functor.map_homological_complex_map_f,
      homological_complex.hom.sq_from_right,
      category_theory.iso.refl_hom,
      homology.π'_iso_cokernel_lift_hom_assoc,
      category_theory.arrow.iso_mk_hom_right,
      category_theory.arrow.iso_mk_hom_left,
      category_theory.limits.cokernel.map_arrow_iso_hom,
      category_theory.functor.comp_map,
      homology_functor_map,
      category_theory.iso.symm_hom,
      category_theory.limits.cokernel.π_desc_assoc,
      category_theory.limits.preserves_cokernel.iso_inv,
      category_theory.functor.map_iso_symm,
      category_theory.category.assoc,
      category_theory.iso.trans_hom,
      homological_complex.hom.sq_to_right,
      category_theory.limits.π_comp_cokernel_comparison_assoc,
      homology.π'_map_assoc],
    simp only [← functor.map_comp],
    rw [homology.π'_iso_cokernel_lift_inv_assoc, homology.π'_iso_cokernel_lift_inv, homology.π'_map,
      F.map_comp, preserves_kernel_iso_inv_map_assoc],
    simp only [← category.assoc],
    congr' 2,
    ext,
    simp only [category_theory.limits.equalizer_as_kernel,
      homological_complex.hom.sq_from_right,
      category_theory.category.assoc,
      category_theory.limits.kernel.lift_ι,
      homological_complex.hom.sq_to_right,
      category_theory.limits.kernel.lift_ι_assoc],
    dsimp,
    rw [category.id_comp, category.comp_id] }
end
.

-- def preserves_limit_of_lim_commute (J : Type*) [category J] [has_limits_of_shape J C]
--   [has_limits_of_shape J D]  (F : C ⥤ D) (e : lim ⋙ F ≅ (whiskering_right J C D).obj F ⋙ lim):
--     preserves_limits_of_shape J F :=
-- begin
--   refine ⟨λ K, preserves_limit_of_preserves_limit_cone (limit.is_limit _) _⟩,
--   apply is_limit.of_iso_limit (limit.is_limit _),
--   ext, swap,
--   { exact e.symm.app K },
--   { dsimp,
--     have := congr_arg (λ f, f ≫ limit.π _ j) (e.hom.naturality (limit.cone K).π),
--     dsimp at this,
--     simp only [whisker_right_app, limit.cone_π, lim_map_π, category.assoc] at this,
--     let : limit K ≅ limit ((category_theory.functor.const J).obj (limit K)),
--     { refine ⟨limit.lift _ ⟨_, 𝟙 _⟩, lim_map (limit.cone K).π, _, _⟩,
--       { ext, simp },
--       { ext, simp, dsimp, simp,  } }  }
--   -- have := cone.iso_mk
-- end


import analysis.topology.topological_space
import analysis.topology.continuity
import analysis.topology.topological_structures
import ex2

open tactic expr function has_add
variables {X : Type*} {Y : Type*} {Z : Type*} {W : Type*}
          {f f₁ f₂ : X → Y} {g : Y → Z} {h : Z → W}
variables [topological_space X] [topological_space Y]
          [topological_space Z] [topological_space W]

example [add_monoid X] [topological_add_monoid X]:
  (λ x : X, x + x) = (uncurry add) ∘ (λ x : X, (x, x)) :=
by reflexivity

#check @has_add.add .

-- Some preparation is necessary, has_add.add has 4 (in words four) arguments
-- first count the non-implicit (default) args, then find them

meta def get_app_num_default_args_aux : expr → nat
| (pi _ binder_info.default _ bbody) := 1 + (get_app_num_default_args_aux bbody)
| (pi _ _ _ bbody) := get_app_num_default_args_aux bbody
| _ :=  0

meta def get_app_num_default_args : expr → tactic nat :=
assume e,
do type ← infer_type e, -- the type of a function is a pi type, we inspect the binder_info recursively
  return $ get_app_num_default_args_aux type

meta def ith_default_arg_index_aux : expr → nat → tactic nat
| (expr.pi _ binder_info.default _ _) 0 := return 0
| (expr.pi _ binder_info.default _ bbody) (i + 1) := do idx ← ith_default_arg_index_aux bbody i, return $ idx + 1
| (expr.pi _ _ _ bbody) i := do idx ← ith_default_arg_index_aux bbody i, return $ idx + 1
| e i := do fail $ "can't find " ++ to_string i ++ "th default argument index"

meta def ith_default_arg_index (e : expr) (i : nat) : tactic nat :=
do type ← infer_type e,
   index ← ith_default_arg_index_aux type i,
   return index

meta def get_codomain (e : expr) : tactic expr :=
do t ← infer_type e,
match t with
| `(%%domain → %%codomain) := return codomain
| _ := fail $ "Can't determine codomain, '" ++ to_string t ++ "' is not a function type."
end

--now we can 'uncurry' and move λ inside

/- Push a given lambda expression inside in the goal:
 -
 - Takes an expression of the form 'λ x, f _[x]',
 - creates a hypothesis 'λ x, f _[x] = f ∘ (λ x, _[x])',
 - and rewrites the main goal using this hypothesis.
 -
 - Tries to uncurry if there is a curried function with two arguments.
 -
 - Fails if it 'doesn't simplify'.
 -/
meta def push_lam_inside2 (e : expr): tactic unit :=
--do trace $ to_raw_fmt e,
do lam name binfo bdomain bbody ← return e
       <|> (fail "The given expression must be a λ."),
  if ¬ is_app bbody
  then fail $ "The outer most part of the lambda expression '" ++ (to_string e) ++
              "' is not a function application."
  else do
    -- we use fancier versions instead of simple pattern matching
    -- because there are many curried arguments now
    fn ← return $ get_app_fn bbody,
    arg ← return $ app_arg bbody,
    num_default_args ← get_app_num_default_args fn,

    -- uncurry if necessary, then push λ inside
    match num_default_args with
    | 2 := do -- there are two default arguments, uncurry and push lambda inside

      -- get first argument and argument type
      arg0_idx ← ith_default_arg_index fn 0,
      arg0 ← return $ ith_arg bbody arg0_idx,
      arg0_type ← get_codomain (expr.lam name binfo bdomain arg0),

      -- get second argument and argument type
      arg1_idx ← ith_default_arg_index fn 1,
      arg1 ← return $ ith_arg bbody arg1_idx,
      arg1_type ← get_codomain (expr.lam name binfo bdomain arg1),

      -- create the inner expression, i.e. λ x, (arg0[x], arg1[x])
      inner_body_app ← to_expr ``(@prod.mk %%arg0_type %%arg1_type),
      inner ← return $ expr.lam name binfo bdomain
                       (expr.app (expr.app inner_body_app arg0) arg1),

      -- create the outer expression, i.e. (uncurry f)
      expr.const fn_name _ ← return fn,
      outer ← return $ @expr.const ff fn_name [],

      -- create term 'original = outer ∘ inner', need to hint types here
      -- i.e. need to use @comp instead of $∘
      can_uncurry ← to_expr ``(%%e = @comp %%bdomain (%%arg0_type × %%arg1_type) _
                                           (uncurry %%outer) %%inner),

      -- create hypothesis and prove it by reflexivity
      h_can_uncurry ← assert "can_uncurry" can_uncurry,
      reflexivity <|> rotate 1,

      -- rewrite target
      rewrite_target h_can_uncurry,
      to_expr ``(function.uncurry_def) >>= rewrite_target,

      -- fail if the outer or inner part is the same as the original expression
      `(continuous $ %%outer ∘ %%inner) ← target,
      (success_if_fail $ unify e inner) <|> fail "inner not changed!",
      (success_if_fail $ unify e outer) <|> fail "outer not changed!",

      -- done!
      return ()

    | 1 := do -- same as before
      -- create hypothesis
      can_push_inside ← to_expr ``(%%e = %%fn ∘ %%(expr.lam name binfo bdomain arg)),
      -- prove hypothesis
      h_can_push_inside ← assert "can_push_λ_inside" can_push_inside,
      reflexivity <|> fail "Can't prove that λ can be pushed inside by reflexivity.",
      -- rewrite target
      rewrite_target h_can_push_inside,
      return ()
    | _ := fail "uncurrying more than two arguements is not implemented"
    end

example [add_monoid X] [topological_add_monoid X] : (continuous (λ x : X, x + x)) :=
begin
  (do `(continuous %%e) ← target,
    push_lam_inside2 e,
    return ()),
  contcomp2,
  exact topological_add_monoid.continuous_add X,
  sorry
end

example [add_monoid X] [topological_add_monoid X] : (continuous (λ x : X, (x, x))) :=
by sorry

-- Same as contcomp2, bu uses push_lam_inside2
meta def contcomp3 : tactic unit :=
do `(continuous %%e) ← target <|> fail "goal has to be of the form 'continuous _'",

  -- if the goal is to show that the expression e is continuous, check if it is an assumption
  assumption <|>

  -- if e is not continuous by assumption, check if it is of the form 'f ∘ g' for some f and g
  match e with
  | `(%%outer ∘ %%inner) :=
    do
    -- assert that the outer function is continuous, if not, rotate the goal away
    outer_continuous ← to_expr ``(continuous %%outer),
    outer_is_continuous ← assert "h_outer_cont" outer_continuous,
    contcomp <|> rotate 1,

    -- assert that the inner function is continuous, if not, rotate the goal away
    inner_continuous ← to_expr ``(continuous %%inner),
    inner_is_continuous ← assert "h_inner_cont" inner_continuous,
    contcomp <|> rotate 1,

    -- knowing that inner and outer function are continuous, apply the theorem continuous.comp
    -- which shows that the composite is continuous
    cont_comp ← to_expr ``(continuous.comp %%inner_is_continuous %%outer_is_continuous),
    exact cont_comp
  | `(λ _, _) :=
    -- if we can move the lambda inside, to that and apply contcomp2 recursively
    do push_lam_inside2 e <|> fail "can't move lambda inside",
       contcomp3
  | _ := fail "neither composite nor lambda expression"
  end

example [add_monoid X] [topological_add_monoid X] : (continuous (λ x : X, x + x)) :=
begin
  contcomp3,
  exact topological_add_monoid.continuous_add X,
  sorry
end

example [add_monoid X] [topological_add_monoid X] : (continuous (λ x : X, (x, x))) :=
by sorry