/-
Copyright (c) 2019 Seul Baek. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Seul Baek
-/
import data.list.prod_sigma
import tactic.omega.clause
import tactic.omega.int.form

/-!
# DNF transformation
-/

namespace omega
namespace int

open_locale omega.int

/-- push_neg p returns the result of normalizing ¬ p by
    pushing the outermost negation all the way down,
    until it reaches either a negation or an atom -/
@[simp] def push_neg : preform → preform
| (p ∨* q) := (push_neg p) ∧* (push_neg q)
| (p ∧* q) := (push_neg p) ∨* (push_neg q)
| (¬*p)    := p
| p        := ¬* p

lemma push_neg_equiv :
  ∀ {p : preform}, preform.equiv (push_neg p) (¬* p) :=
begin
  preform.induce `[intros v; try {refl}],
  { simp only [not_not, push_neg, preform.holds] },
  { simp only [preform.holds, push_neg, not_or_distrib, ihp v, ihq v] },
  { simp only [preform.holds, push_neg, not_and_distrib, ihp v, ihq v] }
end

/-- NNF transformation -/
def nnf : preform → preform
| (¬* p)   := push_neg (nnf p)
| (p ∨* q) := (nnf p) ∨* (nnf q)
| (p ∧* q) := (nnf p) ∧* (nnf q)
| a        := a

def is_nnf : preform → Prop
| (t =* s) := true
| (t ≤* s) := true
| ¬*(t =* s) := true
| ¬*(t ≤* s) := true
| (p ∨* q) := is_nnf p ∧ is_nnf q
| (p ∧* q) := is_nnf p ∧ is_nnf q
| _ := false

lemma is_nnf_push_neg : ∀ p : preform, is_nnf p → is_nnf (push_neg p) :=
begin
  preform.induce `[intro h1; try {trivial}],
  { cases p; try {cases h1}; trivial },
  { cases h1, constructor; [{apply ihp}, {apply ihq}]; assumption },
  { cases h1, constructor; [{apply ihp}, {apply ihq}]; assumption }
end

/-- Argument is free of negations -/
def neg_free : preform → Prop
| (t =* s) := true
| (t ≤* s) := true
| (p ∨* q) := neg_free p ∧ neg_free q
| (p ∧* q) := neg_free p ∧ neg_free q
| _        := false

lemma is_nnf_nnf : ∀ p : preform, is_nnf (nnf p) :=
begin
  preform.induce `[try {trivial}],
  { apply is_nnf_push_neg _ ih },
  { constructor; assumption },
  { constructor; assumption }
end

lemma nnf_equiv : ∀ {p : preform}, preform.equiv (nnf p) p :=
begin
  preform.induce `[intros v; try {refl}; simp only [nnf]],
  { rw push_neg_equiv,
    apply not_iff_not_of_iff, apply ih },
  { apply pred_mono_2' (ihp v) (ihq v) },
  { apply pred_mono_2' (ihp v) (ihq v) }
end

/-- Eliminate all negations from preform -/
@[simp] def neg_elim : preform → preform
| (¬* (t =* s)) := (t.add_one ≤* s) ∨* (s.add_one ≤* t)
| (¬* (t ≤* s)) := s.add_one ≤* t
| (p ∨* q) := (neg_elim p) ∨* (neg_elim q)
| (p ∧* q) := (neg_elim p) ∧* (neg_elim q)
| p        := p

lemma neg_free_neg_elim : ∀ p : preform, is_nnf p → neg_free (neg_elim p) :=
begin
  preform.induce `[intro h1, try {simp only [neg_free, neg_elim]}, try {trivial}],
  { cases p; try {cases h1}; try {trivial}, constructor; trivial },
  { cases h1, constructor; [{apply ihp}, {apply ihq}]; assumption },
  { cases h1, constructor; [{apply ihp}, {apply ihq}]; assumption }
end

lemma le_and_le_iff_eq {α : Type} [partial_order α] {a b : α} :
  (a ≤ b ∧ b ≤ a) ↔ a = b :=
begin
  constructor; intro h1,
  { cases h1, apply le_antisymm; assumption },
  { constructor; apply le_of_eq; rw h1 }
end

lemma implies_neg_elim : ∀ {p : preform}, preform.implies p (neg_elim p) :=
begin
  preform.induce `[intros v h, try {apply h}],
  { cases p with t s t s; try {apply h},
    { simp only [le_and_le_iff_eq.symm,
        not_and_distrib, not_le,
        preterm.val, preform.holds] at h,
      simp only [int.add_one_le_iff, preterm.add_one,
        preterm.val, preform.holds, neg_elim],
      rw or_comm, assumption },
    { simp only [not_le, int.add_one_le_iff,
        preterm.add_one, not_le, preterm.val,
        preform.holds, neg_elim] at *,
      assumption} },
  { simp only [neg_elim], cases h; [{left, apply ihp},
    {right, apply ihq}]; assumption },
  { apply and.imp (ihp _) (ihq _) h }
end

@[simp] def dnf_core : preform → list clause
| (p ∨* q) := (dnf_core p) ++ (dnf_core q)
| (p ∧* q) :=
  (list.product (dnf_core p) (dnf_core q)).map
  (λ pq, clause.append pq.fst pq.snd)
| (t =* s) := [([term.sub (canonize s) (canonize t)],[])]
| (t ≤* s) := [([],[term.sub (canonize s) (canonize t)])]
| (¬* _)   := []

/-- DNF transformation -/
def dnf (p : preform) : list clause :=
dnf_core $ neg_elim $ nnf p

lemma exists_clause_holds {v : nat → int} :
  ∀ {p : preform}, neg_free p → p.holds v → ∃ c ∈ (dnf_core p), clause.holds v c :=
begin
  preform.induce `[intros h1 h2],
  { apply list.exists_mem_cons_of, constructor,
    { simp only [preterm.val, preform.holds] at h2,
      rw [list.forall_mem_singleton],
      simp only [h2, omega.int.val_canonize,
        omega.term.val_sub, sub_self] },
    { apply list.forall_mem_nil } },
  { apply list.exists_mem_cons_of, constructor,
    { apply list.forall_mem_nil },
    { simp only [preterm.val, preform.holds] at h2 ,
      rw [list.forall_mem_singleton],
      simp only [val_canonize,
        preterm.val, term.val_sub],
      rw [le_sub_comm, sub_zero], assumption } },
  { cases h1 },
  { cases h2 with h2 h2;
    [ {cases (ihp h1.left h2) with c h3},
      {cases (ihq h1.right h2) with c h3}];
    cases h3 with h3 h4;
    refine ⟨c, list.mem_append.elim_right _, h4⟩;
    [left,right]; assumption },
  { rcases (ihp h1.left h2.left) with ⟨cp, hp1, hp2⟩,
    rcases (ihq h1.right h2.right) with ⟨cq, hq1, hq2⟩,
    refine ⟨clause.append cp cq, ⟨_, clause.holds_append hp2 hq2⟩⟩,
    simp only [dnf_core, list.mem_map],
    refine ⟨(cp,cq),⟨_,rfl⟩⟩,
    rw list.mem_product,
    constructor; assumption }
end

lemma clauses_sat_dnf_core {p : preform} :
  neg_free p → p.sat → clauses.sat (dnf_core p) :=
begin
  intros h1 h2, cases h2 with v h2,
  rcases (exists_clause_holds h1 h2) with ⟨c,h3,h4⟩,
  refine ⟨c,h3,v,h4⟩
end

lemma unsat_of_clauses_unsat {p : preform} :
clauses.unsat (dnf p) → p.unsat :=
begin
  intros h1 h2, apply h1,
  apply clauses_sat_dnf_core,
  apply neg_free_neg_elim _ (is_nnf_nnf _),
  apply preform.sat_of_implies_of_sat implies_neg_elim,
  have hrw := exists_congr (@nnf_equiv p),
  apply hrw.elim_right h2
end

end int

end omega


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

! This file was ported from Lean 3 source module category_theory.structured_arrow
! leanprover-community/mathlib commit fef8efdf78f223294c34a41875923ab1272322d4
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.PUnit
import Mathlib.CategoryTheory.Comma
import Mathlib.CategoryTheory.Limits.Shapes.Terminal
import Mathlib.CategoryTheory.EssentiallySmall

/-!
# The category of "structured arrows"

For `T : C ⥤ D`, a `T`-structured arrow with source `S : D`
is just a morphism `S ⟶ T.obj Y`, for some `Y : C`.

These form a category with morphisms `g : Y ⟶ Y'` making the obvious diagram commute.

We prove that `𝟙 (T.obj Y)` is the initial object in `T`-structured objects with source `T.obj Y`.
-/

namespace CategoryTheory

-- morphism levels before object levels. See note [CategoryTheory universes].
universe v₁ v₂ v₃ v₄ u₁ u₂ u₃ u₄

variable {C : Type u₁} [Category.{v₁} C] {D : Type u₂} [Category.{v₂} D]

/-- The category of `T`-structured arrows with domain `S : D` (here `T : C ⥤ D`),
has as its objects `D`-morphisms of the form `S ⟶ T Y`, for some `Y : C`,
and morphisms `C`-morphisms `Y ⟶ Y'` making the obvious triangle commute.
-/
-- @[nolint has_nonempty_instance]
def StructuredArrow (S : D) (T : C ⥤ D) :=
  Comma (Functor.fromPUnit S) T
#align category_theory.structured_arrow CategoryTheory.StructuredArrow

-- Porting note: not found by inferInstance
instance (S : D) (T : C ⥤ D) : Category (StructuredArrow S T) := commaCategory

namespace StructuredArrow

/-- The obvious projection functor from structured arrows. -/
@[simps!]
def proj (S : D) (T : C ⥤ D) : StructuredArrow S T ⥤ C :=
  Comma.snd _ _
#align category_theory.structured_arrow.proj CategoryTheory.StructuredArrow.proj

variable {S S' S'' : D} {Y Y' : C} {T : C ⥤ D}

-- porting note: this lemma was added because `Comma.hom_ext`
-- was not triggered automatically
@[ext]
lemma hom_ext {X Y : StructuredArrow S T} (f g : X ⟶ Y) (h : f.right = g.right) : f = g :=
  CommaMorphism.ext _ _ (Subsingleton.elim _ _) h

/-- Construct a structured arrow from a morphism. -/
def mk (f : S ⟶ T.obj Y) : StructuredArrow S T :=
  ⟨⟨⟨⟩⟩, Y, f⟩
#align category_theory.structured_arrow.mk CategoryTheory.StructuredArrow.mk

@[simp]
theorem mk_left (f : S ⟶ T.obj Y) : (mk f).left = ⟨⟨⟩⟩ :=
  rfl
#align category_theory.structured_arrow.mk_left CategoryTheory.StructuredArrow.mk_left

@[simp]
theorem mk_right (f : S ⟶ T.obj Y) : (mk f).right = Y :=
  rfl
#align category_theory.structured_arrow.mk_right CategoryTheory.StructuredArrow.mk_right

@[simp]
theorem mk_hom_eq_self (f : S ⟶ T.obj Y) : (mk f).hom = f :=
  rfl
#align category_theory.structured_arrow.mk_hom_eq_self CategoryTheory.StructuredArrow.mk_hom_eq_self

@[reassoc (attr := simp)]
theorem w {A B : StructuredArrow S T} (f : A ⟶ B) : A.hom ≫ T.map f.right = B.hom := by
  have := f.w ; aesop_cat
#align category_theory.structured_arrow.w CategoryTheory.StructuredArrow.w

@[simp]
theorem comp_right {X Y Z : StructuredArrow S T} (f : X ⟶ Y) (g : Y ⟶ Z) :
  (f ≫ g).right = f.right ≫ g.right := rfl

@[simp]
theorem id_right (X : StructuredArrow S T) :
  (𝟙 X : X ⟶ X).right = 𝟙 X.right := rfl

@[simp]

/-- To construct a morphism of structured arrows,
we need a morphism of the objects underlying the target,
and to check that the triangle commutes.
-/
@[simps]
def homMk {f f' : StructuredArrow S T} (g : f.right ⟶ f'.right) (w : f.hom ≫ T.map g = f'.hom) :
    f ⟶ f' where
  left := eqToHom (by ext)
  right := g
  w := by
    dsimp
    simpa using w.symm
#align category_theory.structured_arrow.hom_mk CategoryTheory.StructuredArrow.homMk

/- Porting note : it appears the simp lemma is not getting generated but the linter
picks up on it (seems like a bug). Either way simp solves it.  -/
attribute [-simp, nolint simpNF] homMk_left

/-- Given a structured arrow `X ⟶ F(U)`, and an arrow `U ⟶ Y`, we can construct a morphism of
structured arrow given by `(X ⟶ F(U)) ⟶ (X ⟶ F(U) ⟶ F(Y))`.
-/
def homMk' {F : C ⥤ D} {X : D} {Y : C} (U : StructuredArrow X F) (f : U.right ⟶ Y) :
    U ⟶ mk (U.hom ≫ F.map f) where
  left := by cases U.left; exact 𝟙 _
  right := f
#align category_theory.structured_arrow.hom_mk' CategoryTheory.StructuredArrow.homMk'

/-- To construct an isomorphism of structured arrows,
we need an isomorphism of the objects underlying the target,
and to check that the triangle commutes.
-/
@[simps!]
def isoMk {f f' : StructuredArrow S T} (g : f.right ≅ f'.right) (w : f.hom ≫ T.map g.hom = f'.hom) :
    f ≅ f' :=
  Comma.isoMk (eqToIso (by ext)) g (by simpa [eqToHom_map] using w.symm)
#align category_theory.structured_arrow.iso_mk CategoryTheory.StructuredArrow.isoMk

/- Porting note : it appears the simp lemma is not getting generated but the linter
picks up on it. Either way simp solves these. -/
attribute [-simp, nolint simpNF] isoMk_hom_left_down_down isoMk_inv_left_down_down

theorem ext {A B : StructuredArrow S T} (f g : A ⟶ B) : f.right = g.right → f = g :=
  CommaMorphism.ext _ _ (Subsingleton.elim _ _)
#align category_theory.structured_arrow.ext CategoryTheory.StructuredArrow.ext

theorem ext_iff {A B : StructuredArrow S T} (f g : A ⟶ B) : f = g ↔ f.right = g.right :=
  ⟨fun h => h ▸ rfl, ext f g⟩
#align category_theory.structured_arrow.ext_iff CategoryTheory.StructuredArrow.ext_iff

instance proj_faithful : Faithful (proj S T) where
  map_injective {_ _} := ext
#align category_theory.structured_arrow.proj_faithful CategoryTheory.StructuredArrow.proj_faithful

/-- The converse of this is true with additional assumptions, see `mono_iff_mono_right`. -/
theorem mono_of_mono_right {A B : StructuredArrow S T} (f : A ⟶ B) [h : Mono f.right] : Mono f :=
  (proj S T).mono_of_mono_map h
#align category_theory.structured_arrow.mono_of_mono_right CategoryTheory.StructuredArrow.mono_of_mono_right

theorem epi_of_epi_right {A B : StructuredArrow S T} (f : A ⟶ B) [h : Epi f.right] : Epi f :=
  (proj S T).epi_of_epi_map h
#align category_theory.structured_arrow.epi_of_epi_right CategoryTheory.StructuredArrow.epi_of_epi_right

instance mono_homMk {A B : StructuredArrow S T} (f : A.right ⟶ B.right) (w) [h : Mono f] :
    Mono (homMk f w) :=
  (proj S T).mono_of_mono_map h
#align category_theory.structured_arrow.mono_hom_mk CategoryTheory.StructuredArrow.mono_homMk

instance epi_homMk {A B : StructuredArrow S T} (f : A.right ⟶ B.right) (w) [h : Epi f] :
    Epi (homMk f w) :=
  (proj S T).epi_of_epi_map h
#align category_theory.structured_arrow.epi_hom_mk CategoryTheory.StructuredArrow.epi_homMk

/-- Eta rule for structured arrows. Prefer `StructuredArrow.eta`, since equality of objects tends
    to cause problems. -/
theorem eq_mk (f : StructuredArrow S T) : f = mk f.hom := by
  cases f
  congr
#align category_theory.structured_arrow.eq_mk CategoryTheory.StructuredArrow.eq_mk

/-- Eta rule for structured arrows. -/
@[simps!]
def eta (f : StructuredArrow S T) : f ≅ mk f.hom :=
  isoMk (Iso.refl _) (by aesop_cat)
#align category_theory.structured_arrow.eta CategoryTheory.StructuredArrow.eta

/- Porting note : it appears the simp lemma is not getting generated but the linter
picks up on it. Either way simp solves these. -/
attribute [-simp, nolint simpNF] eta_hom_left_down_down eta_inv_left_down_down

/-- A morphism between source objects `S ⟶ S'`
contravariantly induces a functor between structured arrows,
`StructuredArrow S' T ⥤ StructuredArrow S T`.

Ideally this would be described as a 2-functor from `D`
(promoted to a 2-category with equations as 2-morphisms)
to `Cat`.
-/
@[simps!]
def map (f : S ⟶ S') : StructuredArrow S' T ⥤ StructuredArrow S T :=
  Comma.mapLeft _ ((Functor.const _).map f)
#align category_theory.structured_arrow.map CategoryTheory.StructuredArrow.map

@[simp]
theorem map_mk {f : S' ⟶ T.obj Y} (g : S ⟶ S') : (map g).obj (mk f) = mk (g ≫ f) :=
  rfl
#align category_theory.structured_arrow.map_mk CategoryTheory.StructuredArrow.map_mk

@[simp]
theorem map_id {f : StructuredArrow S T} : (map (𝟙 S)).obj f = f := by
  rw [eq_mk f]
  simp
#align category_theory.structured_arrow.map_id CategoryTheory.StructuredArrow.map_id

@[simp]
theorem map_comp {f : S ⟶ S'} {f' : S' ⟶ S''} {h : StructuredArrow S'' T} :
    (map (f ≫ f')).obj h = (map f).obj ((map f').obj h) := by
  rw [eq_mk h]
  simp
#align category_theory.structured_arrow.map_comp CategoryTheory.StructuredArrow.map_comp

instance proj_reflectsIsomorphisms : ReflectsIsomorphisms (proj S T) where
  reflects {Y Z} f t :=
    ⟨⟨StructuredArrow.homMk
        (inv ((proj S T).map f))
        (by rw [Functor.map_inv, IsIso.comp_inv_eq]; simp),
      by constructor <;> apply CommaMorphism.ext <;> dsimp at t ⊢ <;> simp⟩⟩
#align category_theory.structured_arrow.proj_reflects_iso CategoryTheory.StructuredArrow.proj_reflectsIsomorphisms

open CategoryTheory.Limits

-- attribute [local tidy] tactic.discrete_cases

/-- The identity structured arrow is initial. -/
def mkIdInitial [Full T] [Faithful T] : IsInitial (mk (𝟙 (T.obj Y))) where
  desc c := homMk (T.preimage c.pt.hom) (by simp)
  fac := fun _ ⟨a⟩ => by cases a
  uniq c m _ := by
    apply CommaMorphism.ext
    · aesop_cat
    · apply T.map_injective
      simpa only [homMk_right, T.image_preimage, ← w m] using (Category.id_comp _).symm
#align category_theory.structured_arrow.mk_id_initial CategoryTheory.StructuredArrow.mkIdInitial

variable {A : Type u₃} [Category.{v₃} A] {B : Type u₄} [Category.{v₄} B]

/-- The functor `(S, F ⋙ G) ⥤ (S, G)`. -/
@[simps!]
def pre (S : D) (F : B ⥤ C) (G : C ⥤ D) : StructuredArrow S (F ⋙ G) ⥤ StructuredArrow S G :=
  Comma.preRight _ F G
#align category_theory.structured_arrow.pre CategoryTheory.StructuredArrow.pre

/-- The functor `(S, F) ⥤ (G(S), F ⋙ G)`. -/
@[simps]
def post (S : C) (F : B ⥤ C) (G : C ⥤ D) : StructuredArrow S F ⥤ StructuredArrow (G.obj S) (F ⋙ G)
    where
  obj X :=
    { left := ⟨⟨⟩⟩
      right := X.right
      hom := G.map X.hom }
  map f :=
    { left := 𝟙 ⟨⟨⟩⟩
      right := f.right
      w := by simp [Functor.comp_map, ← G.map_comp, ← f.w] }
#align category_theory.structured_arrow.post CategoryTheory.StructuredArrow.post

instance small_proj_preimage_of_locallySmall {𝒢 : Set C} [Small.{v₁} 𝒢] [LocallySmall.{v₁} D] :
    Small.{v₁} ((proj S T).obj ⁻¹' 𝒢) := by
  suffices (proj S T).obj ⁻¹' 𝒢 = Set.range fun f : ΣG : 𝒢, S ⟶ T.obj G => mk f.2 by
    rw [this]
    infer_instance
  exact Set.ext fun X => ⟨fun h => ⟨⟨⟨_, h⟩, X.hom⟩, (eq_mk _).symm⟩, by aesop_cat⟩
#align category_theory.structured_arrow.small_proj_preimage_of_locally_small CategoryTheory.StructuredArrow.small_proj_preimage_of_locallySmall

end StructuredArrow

/-- The category of `S`-costructured arrows with target `T : D` (here `S : C ⥤ D`),
has as its objects `D`-morphisms of the form `S Y ⟶ T`, for some `Y : C`,
and morphisms `C`-morphisms `Y ⟶ Y'` making the obvious triangle commute.
-/
-- @[nolint has_nonempty_instance] -- Porting note: removed
def CostructuredArrow (S : C ⥤ D) (T : D) :=
  Comma S (Functor.fromPUnit T)
#align category_theory.costructured_arrow CategoryTheory.CostructuredArrow

instance (S : C ⥤ D) (T : D) : Category (CostructuredArrow S T) := commaCategory
namespace CostructuredArrow

/-- The obvious projection functor from costructured arrows. -/
@[simps!]
def proj (S : C ⥤ D) (T : D) : CostructuredArrow S T ⥤ C :=
  Comma.fst _ _
#align category_theory.costructured_arrow.proj CategoryTheory.CostructuredArrow.proj

variable {T T' T'' : D} {Y Y' : C} {S : C ⥤ D}

-- porting note: this lemma was added because `Comma.hom_ext`
-- was not triggered automatically
@[ext]
lemma hom_ext {X Y : CostructuredArrow S T} (f g : X ⟶ Y) (h : f.left = g.left) : f = g :=
  CommaMorphism.ext _ _ h (Subsingleton.elim _ _)

/-- Construct a costructured arrow from a morphism. -/
def mk (f : S.obj Y ⟶ T) : CostructuredArrow S T :=
  ⟨Y, ⟨⟨⟩⟩, f⟩
#align category_theory.costructured_arrow.mk CategoryTheory.CostructuredArrow.mk

@[simp]
theorem mk_left (f : S.obj Y ⟶ T) : (mk f).left = Y :=
  rfl
#align category_theory.costructured_arrow.mk_left CategoryTheory.CostructuredArrow.mk_left

@[simp]
theorem mk_right (f : S.obj Y ⟶ T) : (mk f).right = ⟨⟨⟩⟩ :=
  rfl
#align category_theory.costructured_arrow.mk_right CategoryTheory.CostructuredArrow.mk_right

@[simp]
theorem mk_hom_eq_self (f : S.obj Y ⟶ T) : (mk f).hom = f :=
  rfl
#align category_theory.costructured_arrow.mk_hom_eq_self CategoryTheory.CostructuredArrow.mk_hom_eq_self

-- @[reassoc (attr := simp)] Porting note: simp can solve these
@[reassoc]
theorem w {A B : CostructuredArrow S T} (f : A ⟶ B) : S.map f.left ≫ B.hom = A.hom := by simp
#align category_theory.costructured_arrow.w CategoryTheory.CostructuredArrow.w

@[simp]
theorem comp_left {X Y Z : CostructuredArrow S T} (f : X ⟶ Y) (g : Y ⟶ Z) :
  (f ≫ g).left = f.left ≫ g.left := rfl

@[simp]
theorem id_left (X : CostructuredArrow S T) :
  (𝟙 X : X ⟶ X).left = 𝟙 X.left := rfl

theorem eqToHom_left {X Y : CostructuredArrow S T} (h : X = Y) :
  (eqToHom h).left = eqToHom (by rw [h]) := by
  subst h
  simp only [eqToHom_refl, id_left]

@[simp]
theorem right_eq_id {X Y : CostructuredArrow S T} (f : X ⟶ Y) :
  f.right = 𝟙 _ := rfl

/-- To construct a morphism of costructured arrows,
we need a morphism of the objects underlying the source,
and to check that the triangle commutes.
-/
@[simps!]
def homMk {f f' : CostructuredArrow S T} (g : f.left ⟶ f'.left) (w : S.map g ≫ f'.hom = f.hom) :
    f ⟶ f' where
  left := g
  right := eqToHom (by ext)
  w := by simpa [eqToHom_map] using w
#align category_theory.costructured_arrow.hom_mk CategoryTheory.CostructuredArrow.homMk

/- Porting note : it appears the simp lemma is not getting generated but the linter
picks up on it. Either way simp can prove this -/
attribute [-simp, nolint simpNF] homMk_right_down_down

/-- To construct an isomorphism of costructured arrows,
we need an isomorphism of the objects underlying the source,
and to check that the triangle commutes.
-/
@[simps!]
def isoMk {f f' : CostructuredArrow S T} (g : f.left ≅ f'.left) (w : S.map g.hom ≫ f'.hom = f.hom) :
    f ≅ f' :=
  Comma.isoMk g (eqToIso (by ext)) (by simpa [eqToHom_map] using w)
#align category_theory.costructured_arrow.iso_mk CategoryTheory.CostructuredArrow.isoMk

/- Porting note : it appears the simp lemma is not getting generated but the linter
picks up on it. Either way simp solves these. -/
attribute [-simp, nolint simpNF] isoMk_hom_right_down_down isoMk_inv_right_down_down

theorem ext {A B : CostructuredArrow S T} (f g : A ⟶ B) (h : f.left = g.left) : f = g :=
  CommaMorphism.ext _ _ h (Subsingleton.elim _ _)
#align category_theory.costructured_arrow.ext CategoryTheory.CostructuredArrow.ext

theorem ext_iff {A B : CostructuredArrow S T} (f g : A ⟶ B) : f = g ↔ f.left = g.left :=
  ⟨fun h => h ▸ rfl, ext f g⟩
#align category_theory.costructured_arrow.ext_iff CategoryTheory.CostructuredArrow.ext_iff

instance proj_faithful : Faithful (proj S T) where map_injective {_ _} := ext
#align category_theory.costructured_arrow.proj_faithful CategoryTheory.CostructuredArrow.proj_faithful

theorem mono_of_mono_left {A B : CostructuredArrow S T} (f : A ⟶ B) [h : Mono f.left] : Mono f :=
  (proj S T).mono_of_mono_map h
#align category_theory.costructured_arrow.mono_of_mono_left CategoryTheory.CostructuredArrow.mono_of_mono_left

/-- The converse of this is true with additional assumptions, see `epi_iff_epi_left`. -/
theorem epi_of_epi_left {A B : CostructuredArrow S T} (f : A ⟶ B) [h : Epi f.left] : Epi f :=
  (proj S T).epi_of_epi_map h
#align category_theory.costructured_arrow.epi_of_epi_left CategoryTheory.CostructuredArrow.epi_of_epi_left

instance mono_homMk {A B : CostructuredArrow S T} (f : A.left ⟶ B.left) (w) [h : Mono f] :
    Mono (homMk f w) :=
  (proj S T).mono_of_mono_map h
#align category_theory.costructured_arrow.mono_hom_mk CategoryTheory.CostructuredArrow.mono_homMk

instance epi_homMk {A B : CostructuredArrow S T} (f : A.left ⟶ B.left) (w) [h : Epi f] :
    Epi (homMk f w) :=
  (proj S T).epi_of_epi_map h
#align category_theory.costructured_arrow.epi_hom_mk CategoryTheory.CostructuredArrow.epi_homMk

/-- Eta rule for costructured arrows. Prefer `CostructuredArrow.eta`, as equality of objects tends
    to cause problems. -/
theorem eq_mk (f : CostructuredArrow S T) : f = mk f.hom := by
  cases f
  congr
#align category_theory.costructured_arrow.eq_mk CategoryTheory.CostructuredArrow.eq_mk

/-- Eta rule for costructured arrows. -/
@[simps!]
def eta (f : CostructuredArrow S T) : f ≅ mk f.hom :=
  isoMk (Iso.refl _) (by aesop_cat)
#align category_theory.costructured_arrow.eta CategoryTheory.CostructuredArrow.eta

/- Porting note : it appears the simp lemma is not getting generated but the linter
picks up on it. Either way simp solves these. -/
attribute [-simp, nolint simpNF] eta_hom_right_down_down eta_inv_right_down_down

/-- A morphism between target objects `T ⟶ T'`
covariantly induces a functor between costructured arrows,
`CostructuredArrow S T ⥤ CostructuredArrow S T'`.

Ideally this would be described as a 2-functor from `D`
(promoted to a 2-category with equations as 2-morphisms)
to `Cat`.
-/
@[simps!]
def map (f : T ⟶ T') : CostructuredArrow S T ⥤ CostructuredArrow S T' :=
  Comma.mapRight _ ((Functor.const _).map f)
#align category_theory.costructured_arrow.map CategoryTheory.CostructuredArrow.map

@[simp]
theorem map_mk {f : S.obj Y ⟶ T} (g : T ⟶ T') : (map g).obj (mk f) = mk (f ≫ g) :=
  rfl
#align category_theory.costructured_arrow.map_mk CategoryTheory.CostructuredArrow.map_mk

@[simp]
theorem map_id {f : CostructuredArrow S T} : (map (𝟙 T)).obj f = f := by
  rw [eq_mk f]
  simp
#align category_theory.costructured_arrow.map_id CategoryTheory.CostructuredArrow.map_id

@[simp]
theorem map_comp {f : T ⟶ T'} {f' : T' ⟶ T''} {h : CostructuredArrow S T} :
    (map (f ≫ f')).obj h = (map f').obj ((map f).obj h) := by
  rw [eq_mk h]
  simp
#align category_theory.costructured_arrow.map_comp CategoryTheory.CostructuredArrow.map_comp

instance proj_reflectsIsomorphisms : ReflectsIsomorphisms (proj S T) where
  reflects {Y Z} f t :=
    ⟨⟨CostructuredArrow.homMk
        (inv ((proj S T).map f))
        (by rw [Functor.map_inv, IsIso.inv_comp_eq]; simp),
      by constructor <;> apply Comma.hom_ext <;> dsimp at t ⊢ <;> simp⟩⟩
#align category_theory.costructured_arrow.proj_reflects_iso CategoryTheory.CostructuredArrow.proj_reflectsIsomorphisms

open CategoryTheory.Limits

-- attribute [local tidy] tactic.discrete_cases -- Porting note: removed

/-- The identity costructured arrow is terminal. -/
def mkIdTerminal [Full S] [Faithful S] : IsTerminal (mk (𝟙 (S.obj Y))) where
  lift c := homMk (S.preimage c.pt.hom) (by simp)
  fac := fun _ ⟨a⟩ => by cases a
  uniq := by
    rintro c m -
    apply CommaMorphism.ext
    · apply S.map_injective
      simpa only [homMk_left, S.image_preimage, ← w m] using (Category.comp_id _).symm
    · aesop_cat
#align category_theory.costructured_arrow.mk_id_terminal CategoryTheory.CostructuredArrow.mkIdTerminal

variable {A : Type u₃} [Category.{v₃} A] {B : Type u₄} [Category.{v₄} B]

/-- The functor `(F ⋙ G, S) ⥤ (G, S)`. -/
@[simps!]
def pre (F : B ⥤ C) (G : C ⥤ D) (S : D) : CostructuredArrow (F ⋙ G) S ⥤ CostructuredArrow G S :=
  Comma.preLeft F G _
#align category_theory.costructured_arrow.pre CategoryTheory.CostructuredArrow.pre

/-- The functor `(F, S) ⥤ (F ⋙ G, G(S))`. -/
@[simps]
def post (F : B ⥤ C) (G : C ⥤ D) (S : C) :
    CostructuredArrow F S ⥤ CostructuredArrow (F ⋙ G) (G.obj S) where
  obj X :=
    { left := X.left
      right := ⟨⟨⟩⟩
      hom := G.map X.hom }
  map f :=
    { left := f.left
      right := 𝟙 _
      w := by simp [Functor.comp_map, ← G.map_comp, ← f.w] }
#align category_theory.costructured_arrow.post CategoryTheory.CostructuredArrow.post

instance small_proj_preimage_of_locallySmall {𝒢 : Set C} [Small.{v₁} 𝒢] [LocallySmall.{v₁} D] :
    Small.{v₁} ((proj S T).obj ⁻¹' 𝒢) := by
  suffices (proj S T).obj ⁻¹' 𝒢 = Set.range fun f : ΣG : 𝒢, S.obj G ⟶ T => mk f.2
    by
    rw [this]
    infer_instance
  exact Set.ext fun X => ⟨fun h => ⟨⟨⟨_, h⟩, X.hom⟩, (eq_mk _).symm⟩, by aesop_cat⟩
#align category_theory.costructured_arrow.small_proj_preimage_of_locally_small CategoryTheory.CostructuredArrow.small_proj_preimage_of_locallySmall

end CostructuredArrow

open Opposite

namespace StructuredArrow

/-- For a functor `F : C ⥤ D` and an object `d : D`, we obtain a contravariant functor from the
category of structured arrows `d ⟶ F.obj c` to the category of costructured arrows
`F.op.obj c ⟶ (op d)`.
-/
@[simps]
def toCostructuredArrow (F : C ⥤ D) (d : D) :
    (StructuredArrow d F)ᵒᵖ ⥤ CostructuredArrow F.op (op d) where
  obj X := @CostructuredArrow.mk _ _ _ _ _ (op X.unop.right) F.op X.unop.hom.op
  map f :=
    CostructuredArrow.homMk f.unop.right.op
      (by
        dsimp
        rw [← op_comp, ← f.unop.w, Functor.const_obj_map]
        erw [Category.id_comp])
#align category_theory.structured_arrow.to_costructured_arrow CategoryTheory.StructuredArrow.toCostructuredArrow

/-- For a functor `F : C ⥤ D` and an object `d : D`, we obtain a contravariant functor from the
category of structured arrows `op d ⟶ F.op.obj c` to the category of costructured arrows
`F.obj c ⟶ d`.
-/
@[simps]
def toCostructuredArrow' (F : C ⥤ D) (d : D) :
    (StructuredArrow (op d) F.op)ᵒᵖ ⥤ CostructuredArrow F d
    where
  obj X := @CostructuredArrow.mk _ _ _ _ _ (unop X.unop.right) F X.unop.hom.unop
  map f :=
    CostructuredArrow.homMk f.unop.right.unop
      (by
        dsimp
        rw [← Quiver.Hom.unop_op (F.map (Quiver.Hom.unop f.unop.right)), ← unop_comp, ← F.op_map, ←
          f.unop.w, Functor.const_obj_map]
        erw [Category.id_comp])
#align category_theory.structured_arrow.to_costructured_arrow' CategoryTheory.StructuredArrow.toCostructuredArrow'

end StructuredArrow

namespace CostructuredArrow

/-- For a functor `F : C ⥤ D` and an object `d : D`, we obtain a contravariant functor from the
category of costructured arrows `F.obj c ⟶ d` to the category of structured arrows
`op d ⟶ F.op.obj c`.
-/
@[simps]
def toStructuredArrow (F : C ⥤ D) (d : D) : (CostructuredArrow F d)ᵒᵖ ⥤ StructuredArrow (op d) F.op
    where
  obj X := @StructuredArrow.mk _ _ _ _ _ (op X.unop.left) F.op X.unop.hom.op
  map f :=
    StructuredArrow.homMk f.unop.left.op
      (by
        dsimp
        rw [← op_comp, f.unop.w, Functor.const_obj_map]
        erw [Category.comp_id])
#align category_theory.costructured_arrow.to_structured_arrow CategoryTheory.CostructuredArrow.toStructuredArrow

/-- For a functor `F : C ⥤ D` and an object `d : D`, we obtain a contravariant functor from the
category of costructured arrows `F.op.obj c ⟶ op d` to the category of structured arrows
`d ⟶ F.obj c`.
-/
@[simps]
def toStructuredArrow' (F : C ⥤ D) (d : D) : (CostructuredArrow F.op (op d))ᵒᵖ ⥤ StructuredArrow d F
    where
  obj X := @StructuredArrow.mk _ _ _ _ _ (unop X.unop.left) F X.unop.hom.unop
  map f :=
    StructuredArrow.homMk f.unop.left.unop
      (by
        dsimp
        rw [← Quiver.Hom.unop_op (F.map f.unop.left.unop), ← unop_comp, ← F.op_map, f.unop.w,
          Functor.const_obj_map]
        erw [Category.comp_id])
#align category_theory.costructured_arrow.to_structured_arrow' CategoryTheory.CostructuredArrow.toStructuredArrow'

end CostructuredArrow

/-- For a functor `F : C ⥤ D` and an object `d : D`, the category of structured arrows `d ⟶ F.obj c`
is contravariantly equivalent to the category of costructured arrows `F.op.obj c ⟶ op d`.
-/
def structuredArrowOpEquivalence (F : C ⥤ D) (d : D) :
    (StructuredArrow d F)ᵒᵖ ≌ CostructuredArrow F.op (op d) :=
  Equivalence.mk (StructuredArrow.toCostructuredArrow F d)
    (CostructuredArrow.toStructuredArrow' F d).rightOp
    (NatIso.ofComponents
      (fun X =>
        (@StructuredArrow.isoMk _ _ _ _ _ _ (StructuredArrow.mk (unop X).hom) (unop X) (Iso.refl _)
            (by aesop_cat)).op)
      fun {X Y} f => Quiver.Hom.unop_inj <| by
        apply CommaMorphism.ext <;>
          dsimp [StructuredArrow.isoMk,Comma.isoMk,StructuredArrow.homMk] ; simp )
    (NatIso.ofComponents
      (fun X =>
        @CostructuredArrow.isoMk _ _ _ _ _ _ (CostructuredArrow.mk X.hom) X (Iso.refl _)
          (by aesop_cat)) fun {X Y} f => by
            apply CommaMorphism.ext <;>
              dsimp [CostructuredArrow.isoMk, Comma.isoMk, CostructuredArrow.homMk] ; simp )
#align category_theory.structured_arrow_op_equivalence CategoryTheory.structuredArrowOpEquivalence

/-- For a functor `F : C ⥤ D` and an object `d : D`, the category of costructured arrows
`F.obj c ⟶ d` is contravariantly equivalent to the category of structured arrows
`op d ⟶ F.op.obj c`.
-/
def costructuredArrowOpEquivalence (F : C ⥤ D) (d : D) :
    (CostructuredArrow F d)ᵒᵖ ≌ StructuredArrow (op d) F.op :=
  Equivalence.mk (CostructuredArrow.toStructuredArrow F d)
    (StructuredArrow.toCostructuredArrow' F d).rightOp
    (NatIso.ofComponents
      (fun X =>
        (@CostructuredArrow.isoMk _ _ _ _ _ _ (CostructuredArrow.mk (unop X).hom) (unop X)
            (Iso.refl _) (by aesop_cat)).op)
      fun {X Y} f => Quiver.Hom.unop_inj <| by
        apply CommaMorphism.ext <;>
          dsimp [CostructuredArrow.isoMk, CostructuredArrow.homMk, Comma.isoMk] ; simp )
    (NatIso.ofComponents
      (fun X =>
        @StructuredArrow.isoMk _ _ _ _ _ _ (StructuredArrow.mk X.hom) X (Iso.refl _)
          (by aesop_cat)) fun {X Y} f => by
            apply CommaMorphism.ext <;>
              dsimp [StructuredArrow.isoMk, StructuredArrow.homMk, Comma.isoMk] ; simp )
#align category_theory.costructured_arrow_op_equivalence CategoryTheory.costructuredArrowOpEquivalence

end CategoryTheory


/-
Copyright (c) 2021 David Wärn,. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn, Scott Morrison
Ported by: Joël Riou

! This file was ported from Lean 3 source module combinatorics.quiver.path
! leanprover-community/mathlib commit 18a5306c091183ac90884daa9373fa3b178e8607
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Combinatorics.Quiver.Basic
import Mathlib.Logic.Lemmas

/-!
# Paths in quivers

Given a quiver `V`, we define the type of paths from `a : V` to `b : V` as an inductive
family. We define composition of paths and the action of prefunctors on paths.
-/

open Function

universe v v₁ v₂ u u₁ u₂

namespace Quiver

/-- `Path a b` is the type of paths from `a` to `b` through the arrows of `G`. -/
inductive Path {V : Type u} [Quiver.{v} V] (a : V) : V → Sort max (u + 1) v
  | nil : Path a a
  | cons : ∀ {b c : V}, Path a b → (b ⟶ c) → Path a c
#align quiver.path Quiver.Path

-- See issue lean4#2049
/-- A computable version of `Quiver.Path.rec`. Workaround until Lean has native support for this. -/
def Path.recC.{w, z, t} {V : Type t} [Quiver.{z} V] {a : V} {motive : (b : V) → Path a b → Sort w}
    (nil : motive a Path.nil)
    (cons : ({b c : V} → (p : Path a b) → (e : b ⟶ c) → motive b p → motive c (p.cons e))) :
    {b : V} → (p : Path a b) → motive b p
  | _, .nil => nil
  | _, (.cons p e) => cons p e (Quiver.Path.recC nil cons p)

@[csimp] lemma Path.rec_eq_recC : @Path.rec = @Path.recC := by
  ext V _ a motive nil cons b p
  induction p with
  | nil => rfl
  | cons p e ih =>
    rw [Path.recC, ←ih]

/-- An arrow viewed as a path of length one. -/
def Hom.toPath {V} [Quiver V] {a b : V} (e : a ⟶ b) : Path a b :=
  Path.nil.cons e
#align quiver.hom.to_path Quiver.Hom.toPath

namespace Path

variable {V : Type u} [Quiver V] {a b c d : V}

lemma nil_ne_cons (p : Path a b) (e : b ⟶ a) : Path.nil ≠ p.cons e :=
fun h => by injection h
#align quiver.path.nil_ne_cons Quiver.Path.nil_ne_cons

lemma cons_ne_nil (p : Path a b) (e : b ⟶ a) : p.cons e ≠ Path.nil :=
fun h => by injection h
#align quiver.path.cons_ne_nil Quiver.Path.cons_ne_nil

lemma obj_eq_of_cons_eq_cons {p : Path a b} {p' : Path a c}
  {e : b ⟶ d} {e' : c ⟶ d} (h : p.cons e = p'.cons e') : b = c := by injection h
#align quiver.path.obj_eq_of_cons_eq_cons Quiver.Path.obj_eq_of_cons_eq_cons

lemma heq_of_cons_eq_cons {p : Path a b} {p' : Path a c}
  {e : b ⟶ d} {e' : c ⟶ d} (h : p.cons e = p'.cons e') : HEq p p' := by injection h
#align quiver.path.heq_of_cons_eq_cons Quiver.Path.heq_of_cons_eq_cons

lemma hom_heq_of_cons_eq_cons {p : Path a b} {p' : Path a c}
  {e : b ⟶ d} {e' : c ⟶ d} (h : p.cons e = p'.cons e') : HEq e e' := by injection h
#align quiver.path.hom_heq_of_cons_eq_cons Quiver.Path.hom_heq_of_cons_eq_cons

/-- The length of a path is the number of arrows it uses. -/
def length {a : V} : ∀ {b : V}, Path a b → ℕ
  | _, nil => 0
  | _, cons p _ => p.length + 1
#align quiver.path.length Quiver.Path.length

instance {a : V} : Inhabited (Path a a) :=
  ⟨nil⟩

@[simp]

@[simp]
theorem length_cons (a b c : V) (p : Path a b) (e : b ⟶ c) : (p.cons e).length = p.length + 1 :=
  rfl
#align quiver.path.length_cons Quiver.Path.length_cons

theorem eq_of_length_zero (p : Path a b) (hzero : p.length = 0) : a = b := by
  cases p
  · rfl
  · cases Nat.succ_ne_zero _ hzero
#align quiver.path.eq_of_length_zero Quiver.Path.eq_of_length_zero

/-- Composition of paths. -/
def comp {a b : V} : ∀ {c}, Path a b → Path b c → Path a c
  | _, p, nil => p
  | _, p, cons q e => (p.comp q).cons e
#align quiver.path.comp Quiver.Path.comp

@[simp]
theorem comp_cons {a b c d : V} (p : Path a b) (q : Path b c) (e : c ⟶ d) :
    p.comp (q.cons e) = (p.comp q).cons e :=
  rfl
#align quiver.path.comp_cons Quiver.Path.comp_cons

@[simp]
theorem comp_nil {a b : V} (p : Path a b) : p.comp Path.nil = p :=
  rfl
#align quiver.path.comp_nil Quiver.Path.comp_nil

@[simp]
theorem nil_comp {a : V} : ∀ {b} (p : Path a b), Path.nil.comp p = p
  | _, nil => rfl
  | _, cons p _ => by rw [comp_cons, nil_comp p]
#align quiver.path.nil_comp Quiver.Path.nil_comp

@[simp]
theorem comp_assoc {a b c : V} :
    ∀ {d} (p : Path a b) (q : Path b c) (r : Path c d), (p.comp q).comp r = p.comp (q.comp r)
  | _, _, _, nil => rfl
  | _, p, q, cons r _ => by rw [comp_cons, comp_cons, comp_cons, comp_assoc p q r]
#align quiver.path.comp_assoc Quiver.Path.comp_assoc

@[simp]
theorem length_comp (p : Path a b) : ∀ {c} (q : Path b c), (p.comp q).length = p.length + q.length
  | _, nil => rfl
  | _, cons _ _ => congr_arg Nat.succ (length_comp _ _)
#align quiver.path.length_comp Quiver.Path.length_comp

theorem comp_inj {p₁ p₂ : Path a b} {q₁ q₂ : Path b c} (hq : q₁.length = q₂.length) :
    p₁.comp q₁ = p₂.comp q₂ ↔ p₁ = p₂ ∧ q₁ = q₂ := by
  refine' ⟨fun h => _, by rintro ⟨rfl, rfl⟩; rfl⟩
  induction' q₁ with d₁ e₁ q₁ f₁ ih <;> obtain _ | ⟨q₂, f₂⟩ := q₂
  · exact ⟨h, rfl⟩
  · cases hq
  · cases hq
  · simp only [comp_cons, cons.injEq] at h
    obtain rfl := h.1
    obtain ⟨rfl, rfl⟩ := ih (Nat.succ.inj hq) h.2.1.eq
    rw [h.2.2.eq]
    exact ⟨rfl, rfl⟩
#align quiver.path.comp_inj Quiver.Path.comp_inj

theorem comp_inj' {p₁ p₂ : Path a b} {q₁ q₂ : Path b c} (h : p₁.length = p₂.length) :
    p₁.comp q₁ = p₂.comp q₂ ↔ p₁ = p₂ ∧ q₁ = q₂ :=
  ⟨fun h_eq => (comp_inj <| Nat.add_left_cancel <| by simpa [h] using congr_arg length h_eq).1 h_eq,
    by
    rintro ⟨rfl, rfl⟩
    rfl⟩
#align quiver.path.comp_inj' Quiver.Path.comp_inj'

theorem comp_injective_left (q : Path b c) : Injective fun p : Path a b => p.comp q :=
  fun _ _ h => ((comp_inj rfl).1 h).1
#align quiver.path.comp_injective_left Quiver.Path.comp_injective_left

theorem comp_injective_right (p : Path a b) : Injective (p.comp : Path b c → Path a c) :=
  fun _ _ h => ((comp_inj' rfl).1 h).2
#align quiver.path.comp_injective_right Quiver.Path.comp_injective_right

@[simp]
theorem comp_inj_left {p₁ p₂ : Path a b} {q : Path b c} : p₁.comp q = p₂.comp q ↔ p₁ = p₂ :=
  q.comp_injective_left.eq_iff
#align quiver.path.comp_inj_left Quiver.Path.comp_inj_left

@[simp]
theorem comp_inj_right {p : Path a b} {q₁ q₂ : Path b c} : p.comp q₁ = p.comp q₂ ↔ q₁ = q₂ :=
  p.comp_injective_right.eq_iff
#align quiver.path.comp_inj_right Quiver.Path.comp_inj_right

/-- Turn a path into a list. The list contains `a` at its head, but not `b` a priori. -/
@[simp]
def toList : ∀ {b : V}, Path a b → List V
  | _, nil => []
  | _, @cons _ _ _ c _ p _ => c :: p.toList
#align quiver.path.to_list Quiver.Path.toList

/-- `Quiver.Path.toList` is a contravariant functor. The inversion comes from `Quiver.Path` and
`List` having different preferred directions for adding elements. -/
@[simp]
theorem toList_comp (p : Path a b) : ∀ {c} (q : Path b c), (p.comp q).toList = q.toList ++ p.toList
  | _, nil => by simp
  | _, @cons _ _ _ d _ q _ => by simp [toList_comp]
#align quiver.path.to_list_comp Quiver.Path.toList_comp

theorem toList_chain_nonempty :
    ∀ {b} (p : Path a b), p.toList.Chain (fun x y => Nonempty (y ⟶ x)) b
  | _, nil => List.Chain.nil
  | _, cons p f => p.toList_chain_nonempty.cons ⟨f⟩
#align quiver.path.to_list_chain_nonempty Quiver.Path.toList_chain_nonempty

variable [∀ a b : V, Subsingleton (a ⟶ b)]

theorem toList_injective (a : V) : ∀ b, Injective (toList : Path a b → List V)
  | _, nil, nil, _ => rfl
  | _, nil, @cons _ _ _ c _ p f, h => by cases h
  | _, @cons _ _ _ c _ p f, nil, h => by cases h
  | _, @cons _ _ _ c _ p f, @cons _ _ _ t _ C D, h => by
    simp only [toList, List.cons.injEq] at h
    obtain ⟨rfl, hAC⟩ := h
    simp [toList_injective _ _ hAC]
#align quiver.path.to_list_injective Quiver.Path.toList_injective

@[simp]
theorem toList_inj {p q : Path a b} : p.toList = q.toList ↔ p = q :=
  (toList_injective _ _).eq_iff
#align quiver.path.to_list_inj Quiver.Path.toList_inj

end Path

end Quiver

namespace Prefunctor

open Quiver

variable {V : Type u₁} [Quiver.{v₁} V] {W : Type u₂} [Quiver.{v₂} W] (F : V ⥤q W)

/-- The image of a path under a prefunctor. -/
def mapPath {a : V} : ∀ {b : V}, Path a b → Path (F.obj a) (F.obj b)
  | _, Path.nil => Path.nil
  | _, Path.cons p e => Path.cons (mapPath p) (F.map e)
#align prefunctor.map_path Prefunctor.mapPath

@[simp]
theorem mapPath_nil (a : V) : F.mapPath (Path.nil : Path a a) = Path.nil :=
  rfl
#align prefunctor.map_path_nil Prefunctor.mapPath_nil

@[simp]
theorem mapPath_cons {a b c : V} (p : Path a b) (e : b ⟶ c) :
    F.mapPath (Path.cons p e) = Path.cons (F.mapPath p) (F.map e) :=
  rfl
#align prefunctor.map_path_cons Prefunctor.mapPath_cons

@[simp]
theorem mapPath_comp {a b : V} (p : Path a b) :
    ∀ {c : V} (q : Path b c), F.mapPath (p.comp q) = (F.mapPath p).comp (F.mapPath q)
  | _, Path.nil => rfl
  | c, Path.cons q e => by dsimp; rw [mapPath_comp p q]
#align prefunctor.map_path_comp Prefunctor.mapPath_comp

@[simp]
theorem mapPath_toPath {a b : V} (f : a ⟶ b) : F.mapPath f.toPath = (F.map f).toPath :=
  rfl
#align prefunctor.map_path_to_path Prefunctor.mapPath_toPath

end Prefunctor


/- Lecture 2.4: Functional Programming — Metaprogramming -/

/- Tactics -/

example : true :=
  by tactic.triv

example : true := by do
  tactic.trace "Hello, Metacosmos!",
  tactic.triv

meta def hello_world : tactic unit := do
  tactic.trace "Hello, Metacosmos!",
  tactic.triv

example : true := by hello_world

run_cmd hello_world

open tactic

example (α : Type) (a : α) : true := by do
  trace "local context:",
    local_context >>= trace,
  trace "goals:",
    get_goals >>= trace,
  trace "target:",
    target >>= trace,
  triv

meta def exact_list : list expr → tactic unit
| []        := fail "no matching expression found"
| (e :: es) :=
  (do
    trace "trying ",
    trace e,
    exact e)
  <|> exact_list es

meta def find_assumption : tactic unit := do
  es ← local_context,
  exact_list es

example {p : Prop} {α : Type} (a : α) (h : p) : p := by do
  find_assumption

example {p : Prop} (h : p) : p := by do
  p_proof ← get_local `h,
  trace "p_proof:",
    trace p_proof,
    trace p_proof.to_raw_fmt,
  trace "type of p_proof:",
    infer_type p_proof >>= trace,
  trace "type of type of p_proof:",
    infer_type p_proof >>= infer_type >>= trace,
  apply p_proof

/- Names and expressions -/

#print expr

#check expr tt  -- elaborated expressions
#check expr ff  -- unelaborated expressions (pre-expressions)

#print name

#check (expr.const `ℕ [] : expr)

#check expr.sort level.zero  -- Sort 0, i.e. Prop
#check expr.sort (level.succ level.zero)  -- Sort 1, i.e. Type 0 (Type)

#check expr.app
#check expr.var 0  -- bound variable of De Bruijn index 0
#check (expr.local_const `uniq_name `pp_name binder_info.default `(ℕ) : expr)
#check (expr.mvar `uniq_name `pp_name `(ℕ) : expr)
#check (expr.pi `pp_name binder_info.default `(ℕ) (expr.sort level.zero) : expr)
#check (expr.lam `pp_name binder_info.default `(ℕ) (expr.var 0) : expr)
#check expr.elet
#check expr.macro

/- Name literals -/

run_cmd trace `name.a
run_cmd trace ``true
run_cmd trace ``name.a -- not found

/- Expression literals -/

-- one backtick: fully elaborated expressions (using reflection)

run_cmd do
  let e : expr := `(list.map (λn : ℕ, n + 1) [1, 2, 3]),
  trace e

run_cmd do
  let e : expr := `(list.map _ [1, 2, 3]),  -- error: holes not allowed
  skip

-- two backticks: checked pre-expressions

run_cmd do
  let e₀ : pexpr := ``(list.map (λn, n + 1) [1, 2, 3]),
  let e₁ : pexpr := ``(list.map _ [1, 2, 3]),
  trace e₀,
  trace e₁

-- three backticks: pre-expressions without name checking

run_cmd do
  let e := ```(a),
  trace e

/- Antiquotations -/

run_cmd do
  let x : expr := `(2 : ℕ),
  let e : expr := `(%%x + 1),
  trace e

run_cmd do
  let x : expr := `(@id ℕ),
  let e := ``(list.map %%x),
  trace e

run_cmd do
  let x : expr := `(@id ℕ),
  let e := ```(a _ %%x),
  trace e

/- Pattern matching -/

example : 1 + 2 = 3 := by do
  `(%%a + %%b = %%r) ← target,
  trace a, trace b, trace r,
  `(@eq %%α %%l' %%r') ← target,
  trace α, trace l', trace r',
  exact `(refl _ : 3 = 3)

/- A simple tactic: `destruct_and` -/

example {a b c d : Prop} (h : a ∧ (b ∧ c) ∧ d) : a := and.left h
example {a b c d : Prop} (h : a ∧ (b ∧ c) ∧ d) : b := and.left (and.left (and.right h))
example {a b c d : Prop} (h : a ∧ (b ∧ c) ∧ d) : b ∧ c := and.left (and.right h)

-- `destruct_and_core t h` uses the conjunction `h : t` to prove the current goal
meta def destruct_and_core : expr → expr → tactic unit
| `(%%a ∧ %%b) h :=
    exact h
    <|> (to_expr ``(and.left %%h) >>= destruct_and_core a)
    <|> (to_expr ``(and.right %%h) >>= destruct_and_core b)
| _            h := exact h

meta def destruct_and (h : name) : tactic unit := do
  h ← get_local h,
  t ← infer_type h,
  destruct_and_core t h

example {a b c d : Prop} (h : a ∧ (b ∧ c) ∧ d) : a := by destruct_and `h
example {a b c d : Prop} (h : a ∧ (b ∧ c) ∧ d) : b := by destruct_and `h
example {a b c d : Prop} (h : a ∧ (b ∧ c) ∧ d) : b ∧ c := by destruct_and `h
example {a b c d : Prop} (h : a ∧ (b ∧ c) ∧ d) : b ∧ d := by destruct_and `h  -- fails

#check exact
#check interactive.exact
#check lean.parser

open interactive.types

meta def tactic.interactive.destruct_and (h : interactive.parse ident_) : tactic unit :=
destruct_and h

example {a b c d : Prop} (h : a ∧ (b ∧ c) ∧ d) : a :=
by destruct_and h


import GroundZero.Support
open GroundZero.Proto (idfun Identity Identity.elem Identity.elim)

universe u v w k
def AS {A : Type u} {B : Type v} {C : Type w} (x : A → B → C) (y : A → B) (z : A) := x z (y z)

section
  variable {A : Type u} {B : Type v}

  def Prod.Id {a c : A} {b d : B} (p : a = c) (q : b = d) : (a, b) = (c, d) :=
  begin induction p; induction q; reflexivity end

  def Prod.intro : A → B → A × B := Prod.mk
  def Prod.pr₁   : A × B → A     := Prod.fst
  def Prod.pr₂   : A × B → B     := Prod.snd
end

namespace GroundZero.Types
namespace Equiv

  def Homotopy {A : Type u} {B : A → Type v} (f g : Π x, B x) :=
  Π (x : A), f x = g x
  infix:80 " ~ " => Homotopy

  hott def Homotopy.id {A : Type u} {B : A → Type v} (f : Π x, B x) : f ~ f :=
  begin intro x; reflexivity end

  hott def Homotopy.symm {A : Type u} {B : A → Type v}
    (f g : Π (x : A), B x) (h : f ~ g) : g ~ f :=
  λ x, (h x)⁻¹

  hott def Homotopy.trans {A : Type u} {B : A → Type v}
    {f g h : Π (x : A), B x} (p : f ~ g) (q : g ~ h) : f ~ h :=
  λ x, p x ⬝ q x

  section
    variable {A : Type u} {B : A → Type v}
    instance : @Reflexive  (Π x, B x) (· ~ ·) := ⟨@Homotopy.id A B⟩
    instance : @Symmetric  (Π x, B x) (· ~ ·) := ⟨@Homotopy.symm A B⟩
    instance : @Transitive (Π x, B x) (· ~ ·) := ⟨@Homotopy.trans A B⟩
  end

  hott def Homotopy.Id {A : Type u} {B : A → Type v}
    {f g : Π x, B x} (η : f = g) : f ~ g :=
  begin induction η; reflexivity end

  def linv {A : Type u} {B : Type v} (f : A → B) :=
  Σ (g : B → A), g ∘ f ~ idfun

  def rinv {A : Type u} {B : Type v} (f : A → B) :=
  Σ (g : B → A), f ∘ g ~ idfun

  def biinv {A : Type u} {B : Type v} (f : A → B) :=
  linv f × rinv f

  hott def homotopySquare {A : Type u} {B : Type v}
    {f g : A → B} (H : f ~ g) {x y : A} (p : x = y) :
    H x ⬝ Id.map g p = Id.map f p ⬝ H y :=
  begin induction p; transitivity; apply Id.reflRight; apply Id.reflLeft end
end Equiv

def Equiv (A : Type u) (B : Type v) : Type (max u v) :=
Σ (f : A → B), Equiv.biinv f
infix:25 " ≃ " => Equiv

namespace Equiv
  hott def forward {A : Type u} {B : Type v} (e : A ≃ B) : A → B := e.fst
  instance forwardCoe {A : Type u} {B : Type v} : CoeFun (A ≃ B) (λ _, A → B) := ⟨forward⟩

  hott def left {A : Type u} {B : Type v} (e : A ≃ B) : B → A := e.2.1.1
  hott def right {A : Type u} {B : Type v} (e : A ≃ B) : B → A := e.2.2.1

  hott def leftForward {A : Type u} {B : Type v} (e : A ≃ B) : e.left ∘ e.forward ~ id := e.2.1.2
  hott def forwardRight {A : Type u} {B : Type v} (e : A ≃ B) : e.forward ∘ e.right ~ id := e.2.2.2

  hott def ideqv (A : Type u) : A ≃ A :=
  ⟨idfun, (⟨idfun, idp⟩, ⟨idfun, idp⟩)⟩

  instance : @Reflexive (Type u) (· ≃ ·) := ⟨ideqv⟩

  hott def inveqv {A : Type u} {a b : A} : (a = b) ≃ (b = a) :=
  ⟨Id.inv, (⟨Id.inv, Id.invInv⟩, ⟨Id.inv, Id.invInv⟩)⟩

  hott def biinvTrans {A : Type u} {B : Type v} {C : Type w}
    {f : A → B} {g : B → C} (e₁ : biinv f) (e₂ : biinv g) : biinv (g ∘ f) :=
  (⟨e₁.1.1 ∘ e₂.1.1, λ x, Id.map e₁.1.1 (e₂.1.2 (f x)) ⬝ e₁.1.2 x⟩,
   ⟨e₁.2.1 ∘ e₂.2.1, λ x, Id.map g (e₁.2.2 (e₂.2.1 x)) ⬝ e₂.2.2 x⟩)

  hott def trans {A : Type u} {B : Type v} {C : Type w}
    (f : A ≃ B) (g : B ≃ C) : A ≃ C :=
  ⟨g.1 ∘ f.1, biinvTrans f.2 g.2⟩

  instance : @Transitive (Type u) (· ≃ ·) := ⟨@trans⟩

  hott def idtoeqv {A B : Type u} (p : A = B) : A ≃ B :=
  begin induction p; reflexivity end

  hott def idtoiff {A B : Type u} (p : A = B) : A ↔ B :=
  begin induction p; reflexivity end

  def transport {A : Type u} (B : A → Type v) {a b : A} (p : a = b) : B a → B b :=
  begin induction p; apply idfun end

  hott def subst {A : Type u} {B : A → Type v} {a b : A} (p : a = b) : B a → B b :=
  transport B p

  hott def substInv {A : Type u} {B : A → Type v} {a b : A} (p : a = b) : B b → B a :=
  subst p⁻¹

  hott def transportconst {A B : Type u} : A = B → A → B :=
  transport idfun

  def transportconstInv {A B : Type u} : A = B → B → A :=
  transportconst ∘ Id.symm

  hott def transportconstOverInv {A B : Type u} (p : A = B) :
    Π x, transportconst p⁻¹ x = transportconstInv p x :=
  begin intro x; reflexivity end

  hott def happlyEqv {A : Type u} {B : Type v} {f g : A ≃ B}
    (p : f = g) : f.forward ~ g.forward :=
  begin induction p; reflexivity end

  instance {A : Type u} : @Rewrite A A A Id Id Id := ⟨@Id.trans A⟩

  instance {A : Type u} {B : Type v} (ρ : A → B → Type w) : Rewrite ρ Id ρ :=
  ⟨λ a _ _ R p => transport (ρ a) p R⟩

  instance {A : Type u} {B : Type v} (ρ : A → B → Type w) : Rewrite Id ρ ρ :=
  ⟨λ _ _ c p R => transport (ρ · c) p⁻¹ R⟩

  instance : Rewrite Equiv.{u, v} Equiv.{v, w} Equiv.{u, w} := ⟨@trans⟩

  def depPath {A : Type u} (B : A → Type v) {a b : A} (p : a = b) (u : B a) (v : B b) :=
  Equiv.subst p u = v

  notation u " =[" P ", " p "] " v => depPath P p u v
  notation u " =[" p "] " v       => depPath _ p u v

  hott def depPath.refl {A : Type u} (B : A → Type v) {a : A} (u : B a) : u =[idp a] u :=
  idp u

  instance {A : Type u} (B : A → Type v) (a : A) :
    @Reflexive (B a) (depPath B (idp a)) :=
  ⟨depPath.refl B⟩

  hott def JTrans {A : Type} {a : A} (B : Π x, a = x → Type v)
    {b c : A} (p : a = b) (q : b = c) (w : B a (idp a)) :
      J₁ B w (p ⬝ q) = J₁ (λ x r, B x (p ⬝ r)) (subst (Id.reflRight _)⁻¹ (@Id.rec A a B w b p)) q :=
  begin induction p; induction q; reflexivity end

  hott def compInvCancelCoh {A : Type u} {a b : A} {B : a = b → Type v} (p : a = b) (w : B p) :
    subst (Id.cancelInvComp p p) (transport (λ r, B (r ⬝ p)) (Id.compInv p)⁻¹ w) = w :=
  begin induction p; reflexivity end

  hott def pathoverOfEq {A : Type u} {B : Type v} {a b : A} {a' b' : B}
    (p : a = b) (q : a' = b') : a' =[λ _, B, p] b' :=
  begin induction p; apply q end

  hott theorem transportForwardAndBack {A : Type u} {B : A → Type v}
    {x y : A} (p : x = y) (u : B x) : subst p⁻¹ (subst p u) = u :=
  begin induction p; reflexivity end

  hott theorem transportBackAndForward {A : Type u} {B : A → Type v}
    {x y : A} (p : x = y) (u : B y) : subst p (subst p⁻¹ u) = u :=
  begin induction p; reflexivity end

  hott theorem substComp {A : Type u} {B : A → Type v} {a b c : A}
    (p : a = b) (q : b = c) (x : B a) : subst (p ⬝ q) x = subst q (subst p x) :=
  begin induction p; induction q; reflexivity end

  hott def depSymm {A : Type u} {B : A → Type v} {a b : A}
    (p : a = b) {u : B a} {v : B b} (q : u =[p] v) : v =[p⁻¹] u :=
  begin induction p; exact q⁻¹ end

  hott def depTrans {A : Type u} {B : A → Type v}
    {a b c : A} {p : a = b} {q : b = c} {u : B a} {v : B b} {w : B c}
    (r : u =[p] v) (s : v =[q] w): u =[p ⬝ q] w :=
  begin induction r using Id.casesOn; induction s using Id.casesOn; apply substComp end
  infix:60 " ⬝′ " => depTrans

  hott def depPathTransSymm {A : Type u} {B : A → Type v} {a b c : A} {p : a = b} {q : c = b}
    {x : B a} {y : B c} (η : x =[p ⬝ q⁻¹] y) : x =[p] subst q y :=
  begin induction p; induction q; exact η end

  hott def depPathTransSymmCoh {A : Type u} {B : A → Type v} {a b c : A} {p : a = b} {q : c = b}
    {x : B a} {y : B c} : Π (η : x =[p ⬝ q⁻¹] y), depPathTransSymm η ⬝′ depSymm q (idp _) = η :=
  begin induction p; induction q; intro (η : x = y); induction η; apply idp end

  hott theorem substOverPathComp {A : Type u} {B : A → Type v} {a b c : A}
    (p : a = b) (q : b = c) (x : B a) : subst (p ⬝ q) x = subst q (subst p x) :=
  begin induction p; reflexivity end

  hott theorem substOverInvPath {A : Type u} {B : A → Type v} {a b : A}
    (p : a = b) (x : B b) : subst p⁻¹ x = substInv p x :=
  by reflexivity

  hott def apd {A : Type u} {B : A → Type v} {a b : A}
    (f : Π (x : A), B x) (p : a = b) : subst p (f a) = f b :=
  begin induction p; reflexivity end

  hott lemma apdInv {A : Type u} {B : A → Type v} {a b : A}
    (f : Π (x : A), B x) (p : a = b) : apd f p⁻¹ = depSymm p (apd f p) :=
  begin induction p; reflexivity end

  hott theorem apdFunctoriality {A : Type u} {B : A → Type v} {a b c : A}
    (f : Π x, B x) (p : a = b) (q : b = c) :
    @apd A B a c f (p ⬝ q) = apd f p ⬝′ apd f q :=
  begin induction p; induction q; reflexivity end

  hott def substSquare {A : Type u} {B : A → Type v} {a b : A}
    {p q : a = b} (r : p = q) (u : B a) : subst p u = subst q u :=
  begin induction r; reflexivity end

  notation "subst²" => substSquare

  hott def depPathMap {A : Type u} {B : A → Type v} {δ : A → Type w} {a b : A}
    {p : a = b} {u : B a} {v : B b} (g : Π x, B x → δ x) (q : u =[p] v) : g a u =[p] g b v :=
  begin induction p; induction q using Id.casesOn; reflexivity end

  hott def depPathMap' {A : Type u} {B : Type v} {C : A → Type w} {D : B → Type k}
    {a b : A} {p : a = b} {u : C a} {v : C b} (f : A → B)
    (g : Π x, C x → D (f x)) (q : u =[p] v) : g a u =[Id.map f p] g b v :=
  begin induction p; induction q using Id.casesOn; apply idp end

  def transportInv {A : Type u} (B : A → Type v) {a b : A} (p : a = b) : B b → B a :=
  substInv p

  def transportSquare {A : Type u} (B : A → Type v) {a b : A}
    {p q : a = b} (r : p = q) (u : B a) : subst p u = subst q u :=
  substSquare r u

  notation "transport²" => transportSquare

  hott theorem transportComp {A : Type u} {B : Type v}
    (C : B → Type w) {x y : A} (f : A → B) (p : x = y) (u : C (f x)) :
    transport (C ∘ f) p u = transport C (Id.map f p) u :=
  begin induction p; reflexivity end

  hott theorem transportToTransportconst {A : Type u} (B : A → Type v) {a b : A}
    (p : a = b) (u : B a) : Equiv.transport B p u = Equiv.transportconst (Id.map B p) u :=
  begin induction p; reflexivity end

  hott theorem transportconstOverComposition {A B C : Type u} (p : A = B) (q : B = C) (x : A) :
    transportconst (p ⬝ q) x = transportconst q (transportconst p x) :=
  by apply substOverPathComp

  hott theorem transportComposition {A : Type u} {a x₁ x₂ : A}
    (p : x₁ = x₂) (q : a = x₁) : transport (Id a) p q = q ⬝ p :=
  begin induction p; symmetry; apply Id.reflRight end

  hott theorem transportCompositionRev {A : Type u} {a x₁ x₂ : A}
    (p : x₁ = x₂) (q : x₁ = a) : transport (· = a) p q = p⁻¹ ⬝ q :=
  begin induction p; reflexivity end

  hott theorem transportCharacterization {A : Type u} {B C : A → Type v} {a b : A} (φ : B a → C a)
    (p : a = b) : transport (λ x, B x → C x) p φ = transport C p ∘ φ ∘ transport B p⁻¹ :=
  begin induction p; reflexivity end

  hott theorem transportOverFamily {A : Type u} {x y : A} {B δ : A → Type v}
    (f : Π x, B x → δ x) (p : x = y) (u : B x) : subst p (f x u) = f y (subst p u) :=
  begin induction p; reflexivity end

  hott def apdSqr {A : Type u} {B C : A → Type v} {a b : A} {u : B a} {v : B b} {p : a = b}
    (f : Π {x : A}, B x → C x) (q : u =[p] v) : f u =[p] f v :=
  begin induction p; induction q using Id.casesOn; reflexivity end

  hott def apd₂ {A : Type u} {B : A → Type v} {a b : A} {p q : a = b}
    (f : Π x, B x) (r : p = q) : apd f p =[λ s, subst s (f a) = f b, r] apd f q :=
  begin induction r; reflexivity end

  hott lemma rewriteComp {A : Type u} {a b c : A}
    {p : a = b} {q : b = c} {r : a = c} (h : r = p ⬝ q) : p⁻¹ ⬝ r = q :=
  begin induction p; apply h end

  hott lemma invRewriteComp {A : Type u} {a b c : A}
    {p : a = b} {q : b = c} {r : a = c} (h : p⁻¹ ⬝ r = q) : r = p ⬝ q :=
  begin induction p; apply h end

  hott lemma invCompRewrite {A : Type u} {a b c : A}
    {p : a = b} {q : b = c} {r : a = c} (h : p ⬝ q = r) : p = r ⬝ q⁻¹ :=
  begin induction q; exact (Id.reflRight p)⁻¹ ⬝ h ⬝ (Id.reflRight r)⁻¹ end

  hott lemma mapWithHomotopy {A : Type u} {B : Type v} (f g : A → B) (H : f ~ g) {a b : A} (p : a = b) :
    Id.map f p = H a ⬝ Id.map g p ⬝ (H b)⁻¹ :=
  begin apply invCompRewrite; symmetry; apply homotopySquare end

  hott def pathoverFromTrans {A : Type u} {a b c : A}
    (p : b = c) (q : a = b) (r : a = c) (η : q ⬝ p = r) : q =[p] r :=
  begin induction η; apply transportComposition end

  hott lemma transportInvCompComp {A : Type u} {a b : A} (p : a = b) (q : a = a) :
    Equiv.transport (λ x, x = x) p q = p⁻¹ ⬝ q ⬝ p :=
  begin induction p; symmetry; apply Id.reflRight end

  hott theorem mapFunctoriality {A : Type u} {B : Type v}
    {a b c : A} (f : A → B) {p : a = b} {q : b = c} :
    Id.map f (p ⬝ q) = Id.map f p ⬝ Id.map f q :=
  begin induction p; reflexivity end

  hott lemma transportOverContrMap {A : Type u} {B : Type v} {a b : A} {c : B}
    (f : A → B) (p : a = b) (q : f a = c) :
    Equiv.transport (λ x, f x = c) p q = Id.map f p⁻¹ ⬝ q :=
  begin induction p; reflexivity end

  hott lemma transportOverInvContrMap {A : Type u} {B : Type v} {a b : A} {c : B}
    (f : A → B) (p : a = b) (q : c = f a) :
    Equiv.transport (λ x, c = f x) p q = q ⬝ Id.map f p :=
  begin induction p; symmetry; apply Id.reflRight end

  hott lemma transportOverInvolution {A : Type u} {a b : A} (f : A → A) (p : a = b) (q : f a = a) :
    Equiv.transport (λ x, f x = x) p q = Id.map f p⁻¹ ⬝ q ⬝ p :=
  begin induction p; symmetry; apply Id.reflRight end

  hott lemma transportOverHmtpy {A : Type u} {B : Type v} {a b : A} (f g : A → B) (p : a = b) (q : f a = g a) :
    Equiv.transport (λ x, f x = g x) p q = Id.map f p⁻¹ ⬝ q ⬝ Id.map g p :=
  begin induction p; symmetry; apply Id.reflRight end

  hott lemma idmap {A : Type u} {a b : A} (p : a = b) : Id.map idfun p = p :=
  begin induction p; reflexivity end

  hott lemma constmap {A : Type u} {B : Type v} {a b : A} {c : B}
    (p : a = b) : Id.map (λ _, c) p = idp c :=
  begin induction p; reflexivity end

  hott theorem transportOverDhmtpy {A : Type u} {B : A → Type v} {a b : A}
    (f g : Π x, B x) (p : a = b) (q : f a = g a) :
    Equiv.transport (λ x, f x = g x) p q = (apd f p)⁻¹ ⬝ Id.map (subst p) q ⬝ apd g p :=
  begin induction p; symmetry; transitivity; apply Id.reflRight; apply idmap end

  hott theorem mapOverComp {A : Type u} {B : Type v} {C : Type w} {a b : A}
    (f : A → B) (g : B → C) (p : a = b) :
    @Id.map A C a b (g ∘ f) p = Id.map g (Id.map f p) :=
  begin induction p; reflexivity end

  hott theorem apdOverConstantFamily {A : Type u} {B : Type v} {a b : A}
    (f : A → B) (p : a = b) : apd f p = pathoverOfEq p (Id.map f p) :=
  begin induction p; reflexivity end

  def reflPathover {A : Type u} {B : Type v} {a : A} {x y : B} (p : x =[λ _, B, idp a] y) : x = y := p

  hott lemma pathoverInv {A : Type u} {B : Type v} (a : A) {x y : B} (p : x = y) :
    reflPathover (pathoverOfEq (idp a) p) = p :=
  begin induction p; reflexivity end

  hott def pathoverOfEqInj {A : Type u} {B : Type v} {a b : A} {a' b' : B}
    (r : a = b) (p q : a' = b') (η : pathoverOfEq r p = pathoverOfEq r q) : p = q :=
  begin induction r; apply η end

  hott def transportImpl {A : Type u} (B : A → Type v)
    (C : A → Type w) {a b : A} (p : a = b) (φ : B a → C a) :
    transport (λ x, B x → C x) p φ = λ x, subst p (φ (subst p⁻¹ x)) :=
  begin induction p; reflexivity end

  hott theorem transportOverConstFamily {A : Type u} {B : Type v}
    {a b : A} (p : a = b) (b : B) : transport (λ _, B) p b = b :=
  begin induction p; reflexivity end

  hott theorem transportOverPi {A : Type u} {B : Type v}
    (B : A → B → Type w) {a b : A} (p : a = b) (u : Π y, B a y) :
    transport (λ x, Π y, B x y) p u = (λ y, @transport A (λ x, B x y) a b p (u y)) :=
  begin induction p; reflexivity end

  hott theorem transportOverSig {A : Type u} {B : Type v}
    (B : A → B → Type w) {a b : A} (p : a = b) (u : Σ y, B a y) :
    transport (λ x, Σ y, B x y) p u = ⟨u.1, transport (B · u.1) p u.2⟩ :=
  begin induction p; reflexivity end

  hott theorem transportOverProduct {A : Type u} (F : A → Type v) (G : A → Type w) {a b : A}
    (p : a = b) {w : F a × G a} : transport (λ x, F x × G x) p w = (transport F p w.1, transport G p w.2) :=
  begin induction p; reflexivity end

  hott lemma transportOverFunction {A : Type u} {B : Type v}
    {a : A} {b : B} (f g : A → B) (p : f = g) (q : f a = b) :
    transport (λ (f' : A → B), f' a = b) p q =
    @Id.map (A → B) B g f (λ (f' : A → B), f' a) p⁻¹ ⬝ q :=
  begin induction p; reflexivity end

  hott lemma transportOverOperation {A B : Type u} (φ : A → A → A) (p : A = B) :
    transport (λ A, A → A → A) p φ = λ x y, transport idfun p (φ (transport idfun p⁻¹ x) (transport idfun p⁻¹ y)) :=
  begin induction p; reflexivity end

  hott lemma transportOverFunctor {A B : Type u} (M : Type u → Type v) (N : Type u → Type w)
    (φ : M A → N A) (p : A = B) : transport (λ A, M A → N A) p φ = λ x, subst p (φ (subst p⁻¹ x)) :=
  begin induction p; reflexivity end

  hott lemma transportOverMorphism {A B : Type u} (φ : A → A) (p : A = B) :
    transport (λ A, A → A) p φ = λ x, transport idfun p (φ (transport idfun p⁻¹ x)) :=
  begin induction p; reflexivity end

  hott lemma transportOverOperationPointwise {A B : Type u} (φ : A → A → A) (p : A = B) {x y : B} :
      transport (λ A, A → A → A) p φ x y
    = transport idfun p (φ (transport idfun p⁻¹ x) (transport idfun p⁻¹ y)) :=
  begin induction p; reflexivity end

  hott lemma transportOverMorphismPointwise {A B : Type u} (φ : A → A) (p : A = B) {x : B} :
    transport (λ A, A → A) p φ x = transport idfun p (φ (transport idfun p⁻¹ x)) :=
  begin induction p; reflexivity end

  hott def bimap {A : Type u} {B : Type v} {C : Type w} {a b : A} {a' b' : B}
    (f : A → B → C) (p : a = b) (q : a' = b') : f a a' = f b b' :=
  begin induction p; induction q; reflexivity end

  hott lemma bimapReflLeft {A : Type u} {B : Type v} {C : Type w}
    {a : A} {a' b' : B} (f : A → B → C) (p : a' = b') :
    bimap f (idp a) p = Id.map (f a) p :=
  begin induction p; reflexivity end

  hott lemma bimapReflRight {A : Type u} {B : Type v} {C : Type w}
    {a b : A} {a' : B} (f : A → B → C) (p : a = b) :
    bimap f p (idp a') = Id.map (f · a') p :=
  begin induction p; reflexivity end

  hott theorem bimapCharacterization {A : Type u} {B : Type v} {C : Type w}
    {a b : A} {a' b' : B} (f : A → B → C) (p : a = b) (q : a' = b') :
    bimap f p q = @Id.map A C a b (f · a') p ⬝ Id.map (f b) q :=
  begin induction p; induction q; reflexivity end

  hott theorem bimapCharacterization' {A : Type u} {B : Type v} {C : Type w}
    {a b : A} {a' b' : B} (f : A → B → C) (p : a = b) (q : a' = b') :
    bimap f p q = Id.map (f a) q ⬝ @Id.map A C a b (f · b') p :=
  begin induction p; induction q; reflexivity end

  hott theorem bimapInv {A : Type u} {B : Type v} {C : Type w} {a b : A} {a' b' : B}
    (f : A → B → C) (p : a = b) (q : a' = b') : (bimap f p q)⁻¹ = bimap f p⁻¹ q⁻¹ :=
  begin induction p; induction q; reflexivity end

  hott theorem bimapComp {A : Type u} {B : Type v} {C : Type w}
    {a b : A} {a' b' : B} (f : A → B → C) (p : a = b) (q : a' = b') :
    Id.map (f · a') p = Id.map (f a) q ⬝ bimap f p q⁻¹ :=
  begin
    induction p; symmetry; transitivity; apply Id.map; transitivity;
    apply bimapReflLeft; apply Id.mapInv; apply Id.compInv
  end

  hott theorem mapOverAS {A : Type u} {a b : A} (f : A → A → A) (g : A → A) (p : a = b) :
    Id.map (AS f g) p = @bimap A A A a b (g a) (g b) f p (Id.map g p) :=
  begin induction p; reflexivity end

  hott lemma liftedHapply {A : Type u} (B : A → Type v) (C : A → Type w)
    {a b : A} (p : a = b) (f : B a → C a) (g : B b → C b)
    (q : transport (λ x, B x → C x) p f = g) :
    Π x, transport C p (f x) = g (transport B p x) :=
  begin induction p; induction q; intro x; reflexivity end

  hott statement identityEqv {A : Type u} : A ≃ Identity A :=
  begin
    existsi Identity.elem; apply Prod.mk <;> existsi Identity.elim <;> intro x;
    { reflexivity }; { induction x; reflexivity }
  end

  hott def eqvEqEqv {A B C : Type u} (p : A ≃ B) (q : B = C) : A ≃ C :=
  transport (Equiv A) q p
end Equiv

def isQinv {A : Type u} {B : Type v} (f : A → B) (g : B → A) :=
(f ∘ g ~ idfun) × (g ∘ f ~ idfun)

def Qinv {A : Type u} {B : Type v} (f : A → B) :=
Σ (g : B → A), isQinv f g

namespace Qinv
  def eqv (A : Type u) (B : Type v) :=
  Σ (f : A → B), Qinv f

  hott def toBiinv {A : Type u} {B : Type v} (f : A → B) (q : Qinv f) : Equiv.biinv f :=
  (⟨q.1, q.2.2⟩, ⟨q.1, q.2.1⟩)

  hott def linvInv {A : Type u} {B : Type v}
    (f : A → B) (g : B → A) (h : B → A)
    (G : f ∘ g ~ id) (H : h ∘ f ~ id) : g ∘ f ~ id :=
  let F₁ := λ x, H (g (f x));
  let F₂ := λ x, Id.map h (G (f x));
  λ x, (F₁ x)⁻¹ ⬝ F₂ x ⬝ H x

  hott def rinvInv {A : Type u} {B : Type v}
    (f : A → B) (g : B → A) (h : B → A)
    (G : f ∘ g ~ id) (H : h ∘ f ~ id) : f ∘ h ~ id :=
  let F₁ := λ x, Id.map (f ∘ h) (G x);
  let F₂ := λ x, Id.map f (H (g x));
  λ x, (F₁ x)⁻¹ ⬝ F₂ x ⬝ G x

  hott def ofBiinv {A : Type u} {B : Type v} (f : A → B) (F : Equiv.biinv f) : Qinv f :=
  ⟨F.2.1, (F.2.2, linvInv f F.2.1 F.1.1 F.2.2 F.1.2)⟩

  hott def inv {A : Type u} {B : Type v} (e : eqv A B) : eqv B A :=
  ⟨e.2.1, ⟨e.1, (e.2.2.2, e.2.2.1)⟩⟩

  hott def toEquiv {A : Type u} {B : Type v} (e : eqv A B) : A ≃ B :=
  ⟨e.1, (⟨e.2.1, e.2.2.2⟩, ⟨e.2.1, e.2.2.1⟩)⟩
end Qinv

namespace Equiv
  hott def forwardLeft {A : Type u} {B : Type v} (e : A ≃ B) : e.forward ∘ e.left ~ idfun :=
  begin apply Qinv.rinvInv; apply e.forwardRight; apply e.leftForward end

  hott def rightForward {A : Type u} {B : Type v} (e : A ≃ B) : e.right ∘ e.forward ~ idfun :=
  begin apply Qinv.linvInv; apply e.forwardRight; apply e.leftForward end

  hott def symm {A : Type u} {B : Type v} (f : A ≃ B) : B ≃ A :=
  Qinv.toEquiv (Qinv.inv ⟨f.1, Qinv.ofBiinv f.1 f.2⟩)

  instance : @Symmetric (Type u) (· ≃ ·) := ⟨@Equiv.symm⟩

  hott lemma eqvInj {A : Type u} {B : Type v} (e : A ≃ B)
    (x y : A) (p : e.forward x = e.forward y) : x = y :=
  begin
    transitivity; symmetry; apply e.leftForward;
    transitivity; apply Id.map e.left;
    exact p; apply e.leftForward
  end

  hott lemma eqvLeftInj {A : Type u} {B : Type v} (e : A ≃ B)
    (x y : B) (p : e.left x = e.left y) : x = y :=
  begin
    transitivity; symmetry; apply e.forwardLeft;
    transitivity; apply Id.map e.forward;
    exact p; apply e.forwardLeft
  end

  hott lemma eqvRightInj {A : Type u} {B : Type v} (e : A ≃ B)
    (x y : B) (p : e.right x = e.right y) : x = y :=
  begin
    transitivity; symmetry; apply e.forwardRight;
    transitivity; apply Id.map e.forward;
    exact p; apply e.forwardRight
  end
end Equiv

-- half adjoint equivalence
def Ishae {A : Type u} {B : Type v} (f : A → B) :=
Σ (g : B → A) (η : g ∘ f ~ id) (ϵ : f ∘ g ~ id), Π x, Id.map f (η x) = ϵ (f x)

def fib {A : Type u} {B : Type v} (f : A → B) (y : B) := Σ (x : A), f x = y
def total {A : Type u} (B : A → Type v) := Σ x, B x
def fiberwise {A : Type u} (B : A → Type v) := Π x, B x

end GroundZero.Types


import fol
import to_mathlib
import Rings.Notation
import data.fin
import Rings.ToMathlib.fin
import Rings.ToMathlib.dvector

namespace fol

/-- repeated ∧ for a FOL -/
def bd_big_and {L : Language} {d : ℕ} :
  Π (n : ℕ), (fin n → (bounded_formula L d)) → bounded_formula L d
| nat.zero fs := bd_not bd_falsum
| (nat.succ n) fs := bd_and (bd_big_and n (λ i, fs i)) (fs n)

/-- forward direction for following lemma -/
lemma realize_bounded_formula_bd_alls'_aux {L} {n} : Π {k} {f : bounded_formula L (n + k)}
  {S : Structure L} (v : dvector S n),
  (realize_bounded_formula v (bd_alls' k n f) dvector.nil)
  →
  (∀ xs : dvector S k, realize_bounded_formula (dvector.append xs v) f dvector.nil)
| nat.zero  f S v hf (dvector.nil) :=
by simpa using hf
| (nat.succ n) f S v hf (dvector.cons x xs) :=
begin
  simp only [bd_alls'] at hf,
  have hf' := realize_bounded_formula_bd_alls'_aux v hf xs,
  simp only [realize_bounded_formula] at hf',
  simpa using hf' x,
end

/-- realizing ∀ x_1 ... x_k, f is the same as realizing f for each (x_1 ... x_k) -/
lemma realize_bounded_formula_bd_alls' {L} {n} {k} {f : bounded_formula L (n + k)}
  {S : Structure L} (v : dvector S n) :
  (realize_bounded_formula v (bd_alls' k n f) dvector.nil)
  ↔
  (∀ xs : dvector S k, realize_bounded_formula (dvector.append xs v) f dvector.nil) :=
begin
  split, {apply realize_bounded_formula_bd_alls'_aux},
  intro hf,
  induction k with k hk,
  {simpa using hf dvector.nil},
  {
    simp only [bd_alls'],
    apply hk,
    simp only [realize_bounded_formula],
    intros xs x,
    apply hf (dvector.cons x xs),
  }
end

/-- copy of bd_alls with ∃'s instead--/
@[simp] def bd_exs' {L : Language} (k n : ℕ) :
  bounded_formula L (n + k) → bounded_formula L n :=
λ f, bd_not (bd_alls' k n (bd_not f))

/-- realizing ∀ x_1 ... x_k, f is the same as realizing f for each (x_1 ... x_k) -/
lemma realize_bounded_formula_bd_exs' {L} {n} {k} {f : bounded_formula L (n + k)}
  {S : Structure L} (v : dvector S n) :
  (realize_bounded_formula v (bd_exs' k n f) dvector.nil)
  ↔
  (∃ xs : dvector S k, realize_bounded_formula (dvector.append xs v) f dvector.nil) :=
begin
  have hrw : (∀ (x : dvector ↥S k), ¬realize_bounded_formula (x.append v) f dvector.nil)
    ↔ (∀ (x : dvector ↥S k), realize_bounded_formula (x.append v) (bd_not f) dvector.nil),
  {simp only [realize_bounded_formula_not]},
  simp only [bd_exs'],
  rw [← not_iff_not, not_exists, hrw, realize_bounded_formula_not, not_not,
    realize_bounded_formula_bd_alls'],
end

@[simp] lemma realize_bounded_formula_bd_big_and {L} {S : Structure L} {n : ℕ}
  {v : dvector S n} : Π {m : ℕ} (f : fin m → bounded_formula L n),
  realize_bounded_formula v (bd_big_and m f) dvector.nil
  ↔
  (Π k : fin m, realize_bounded_formula v (f k) dvector.nil)
| nat.zero f :=
begin
  simp only [bd_big_and, realize_bounded_formula_not,
    realize_bounded_formula, true_iff, not_false_iff],
  exact fin_zero_elim,
end
| (nat.succ m) f :=
begin
  simp only [bd_big_and, realize_bounded_formula_and],
  split,
  {
    intros hf k,
    rw realize_bounded_formula_bd_big_and at hf,
    cases fin.lt_or_eq_fin k with hk,
    -- by_cases hk : (k : ℕ) < m,
    {
      have h :=  hf.1 ⟨ k , _ ⟩,
      {simpa using h},
      {
        rw fin.lt_coe_iff_val_lt,
        exact hk,
        exact lt_add_one m,
      },
    },
    {rw h, exact hf.2}
  },
  {
    intro hf,
    split,
    {
      rw realize_bounded_formula_bd_big_and,
      intro k,
      apply hf k,
    },
    {exact hf m}
  },
end

lemma all_realize_sentence_union {L} (S : Structure L) (T₁ T₂ : Theory L) :
  S ⊨ T₁ ∪ T₂ ↔ S ⊨ T₁ ∧ S ⊨ T₂ :=
by simp only [all_realize_sentence, set.mem_union_eq,
  or_imp_distrib, forall_and_distrib]

lemma all_realize_sentence_range {L} {α}
  (S : Structure L) (fs : α → sentence L) :
S ⊨ set.range fs ↔ ∀ a : α, S ⊨ fs a :=
by simp only [all_realize_sentence, forall_apply_eq_imp_iff',
  set.mem_range, exists_imp_distrib]

lemma all_realize_sentence_insert {L} {s : Theory L} (ϕ : sentence L)
  (S : Structure L) :
  S ⊨ set.insert ϕ s ↔ S ⊨ ϕ ∧ S ⊨ s :=
⟨ (λ h, ⟨ h (set.mem_insert _ _) , λ f hf, h (set.mem_insert_of_mem _ hf) ⟩)
  ,
  ( λ h f hf,
  begin
    cases hf with hf hf,
    { rw hf, exact h.1 },
    { exact h.2 hf },
  end ) ⟩

namespace bounded_preterm

-- I don't know if this is already in fol but
@[simp] def lift_succ {L} {n : ℕ} : Π {l},
  fol.bounded_preterm L n l → fol.bounded_preterm L n.succ l
| l (bd_var k) := x_ k
| l (bd_func f) := fol.bounded_preterm.bd_func f
| l (bd_app t s) :=
  fol.bounded_preterm.bd_app (@lift_succ l.succ t) (@lift_succ 0 s)

  -- instance has_lift_succ {L} {n : ℕ} : Π l,
  --   has_lift (fol.bounded_preterm L n l) (fol.bounded_preterm L n.succ l) :=
  --   λ l, ⟨ lift_succ ⟩

lemma lift_succ_x_k {L} {n : ℕ} {k : fin n} :
  lift_succ (x_ k : fol.bounded_preterm L n 0) = x_ k := rfl

lemma realize_lift_succ {L} {n : ℕ} {S : Structure L} :
  Π {l} {t : bounded_preterm L n l} {as : dvector S (n+1)} {bs},
  realize_bounded_term as (lift_succ t) bs
  = realize_bounded_term (dvector.remove_mth n as) t bs
| l (bd_var k) as bs :=
begin
  simp only [lift_succ, realize_bounded_term],
  rw dvector.nth_remove_mth_big_m _ k.2 k.2,
  simp only [fin.val_eq_coe, fin.coe_eq_cast_succ, fin.coe_cast_succ],
end
| l (bd_func f) as bs := by simp only [lift_succ, realize_bounded_term]
| l (bd_app t s) as bs :=
by simp only [lift_succ, realize_bounded_term, realize_lift_succ]

end bounded_preterm

variables {L : Language}

namespace bounded_preformula

lemma bd_not.inj {n} {f0 f1 : bounded_formula L n} :
  ∼ f0 = ∼ f1 → f0 = f1 := λ h, (bd_imp.inj h).1

lemma bd_notequal.inj {n} {t0 t1 s0 s1 : bounded_term L n} :
  t0 ≄ s0 = t1 ≄ s1 → t0 = t1 ∧ s0 = s1 :=
bd_equal.inj ∘ bd_not.inj

end bounded_preformula

-- not to be confused with is_complete
/-- A theory is_complete' if it deduces any sentence or its complement -/
def is_complete' (T : Theory L) : Prop :=
∀ (ϕ : sentence L), T ⊨ ϕ ∨ T ⊨ ∼ ϕ

/-- A theory is_complete'' if deductions for the model transfer to deductions for the theory-/
def is_complete'' (T : Theory L) : Prop :=
∀ (M : Structure L) (hM : nonempty M) (ϕ : sentence L), M ⊨ T → M ⊨ ϕ → T ⊨ ϕ

/-- Note fewer assumptions than the if and only if -/
lemma is_complete''_to_is_complete' {T : Theory L} :
  is_complete' T → is_complete'' T :=
begin
  intros H M hM ϕ hMT hMϕ,
  cases H ϕ with hTϕ hTϕ,
  { exact hTϕ },
  {
    have hbot := hTϕ hM hMT,
    rw realize_sentence_not at hbot,
    exfalso,
    exact hbot hMϕ,
  },
end

/-- When T is satisfied by some model then two notions of complete coincide -/
lemma is_complete''_iff_is_complete' {T : Theory L} (M : Structure L)
  (hM : nonempty M) (hMT : M ⊨ T) :
  is_complete' T ↔ is_complete'' T :=
begin
  split,
  { exact is_complete''_to_is_complete' },
  {
    intros H ϕ,
    by_cases hMϕ : M ⊨ ϕ,
    { left, exact H M hM ϕ hMT hMϕ },
    {
      right,
      rw ← realize_sentence_not at hMϕ,
      exact H M hM _ hMT hMϕ
    },
  },
end

end fol


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

-- Uncomment this line to observe the steps of constructing appropriate equivalences.
-- set_option trace.equiv_rw_type true

-- This fails if we use `occurs` rather than `kdepends_on` in `equiv_rw_type`.
instance : equiv_functor set :=
{ map := λ α β e s, by { equiv_rw e.symm, assumption, } }

-- Rewriting a hypothesis along an equivalence.
example {α β : Type} (e : α ≃ β)
  (f : α → ℕ) (h : ∀ b : β, f (e.symm b) = 0) (i : α) : f i = 0 :=
begin
  equiv_rw e at i,
  apply h,
end

-- Check that dependent hypotheses are reverted and reintroduced.
example {α β : Type} (e : α ≃ β) (Z : α → Type) (f : Π a, Z a → ℕ)
  (h : ∀ (b : β) (x : Z (e.symm b)), f (e.symm b) x = 0)
  (i : α) (x : Z i) : f i x = 0 :=
begin
  equiv_rw e at i,
  guard_hyp i : β,
  guard_target f (e.symm i) x = 0,
  guard_hyp x : Z ((e.symm) i),
  exact h i x,
end

-- Rewriting the goal along an equivalence.
example {α β : Type} (e : α ≃ β) (b : β) : α :=
begin
  equiv_rw e,
  exact b,
end

-- Fail if the equivalence can't be used.
example {α β γ : Type} (e : β ≃ γ) (a : α) : α :=
begin
  success_if_fail { equiv_rw e at a },
  success_if_fail { equiv_rw e },
  exact a,
end

-- Verify that `equiv_rw` will rewrite under `equiv_functor` instances.
example {α β : Type} (u : unique α) (e : α ≃ β) : β :=
begin
  equiv_rw e at u,
  apply inhabited.default,
end

example {α β : Type} (p : equiv.perm α) (e : α ≃ β) : equiv.perm β :=
begin
  equiv_rw e at p,
  exact p,
end

-- We can rewrite the goal under functors.
example {α β : Type} (e : α ≃ β) (b : β) : option α :=
begin
  equiv_rw e,
  exact some b,
end

-- We can rewrite hypotheses under functors.
example {α β : Type} (e : α ≃ β) (b : option α) : option β :=
begin
  equiv_rw e at b,
  exact b,
end

-- We can rewrite hypotheses under compositions of functors.
example {α β : Type} (e : α ≃ β) (b : list (list α)) : list β :=
begin
  equiv_rw e at b,
  exact b.join,
end

-- Check that we can rewrite in the target position of function types.
example {α β γ : Type} (e : α ≃ β) (f : γ → β) : γ → α :=
begin
  equiv_rw e,
  exact f,
end

-- Check that we can rewrite in the source position of function types.
example {α β γ : Type} (e : α ≃ β) (f : β → γ) : α → γ :=
begin
  equiv_rw e,
  exact f,
end

-- Rewriting under multiple functors.
example {α β : Type} (e : α ≃ β) (b : β) : list (option α) :=
begin
  equiv_rw e,
  exact [none, some b],
end

-- Rewriting under multiple functors, including functions.
example {α β γ : Type} (e : α ≃ β) (b : β) : γ → list (option α) :=
begin
  equiv_rw e,
  exact (λ g, [none, some b]),
end

-- Rewriting in multiple positions.
example {α β : Type*} [has_add β] (e : α ≃ β) : α → α :=
begin
  have : (α → α) ≃ _, {
    apply equiv.arrow_congr,
    apply e,
    apply e, },
  equiv_rw e,
  exact (@id β),
end

-- Rewriting in multiple positions.
example {α β : Type} [has_add β] (e : α ≃ β) : β → α → α :=
begin
  equiv_rw e,
  exact (+),
end

-- Rewriting in multiple positions.
example {α β : Type} [has_add β] (e : α ≃ β) : α → α → α :=
begin
  equiv_rw e,
  exact (+),
end

example {α β γ : Type} (e : α ≃ β) (s : β ⊕ γ) : α ⊕ γ :=
begin
  equiv_rw e,
  exact s,
end

example {α β γ : Type} (e : α ≃ β) (s : β ⊕ γ) : (α ⊕ γ) × (γ ⊕ α) :=
begin
  equiv_rw e,
  exact (s, s.swap),
end

example {α β γ : Type} (e : α ≃ β) (s : α ⊕ γ) : (β ⊕ γ) × (γ ⊕ β) :=
begin
  equiv_rw e at s,
  exact (s, s.swap),
end

example {α β γ : Type} (e : α ≃ β) (s : (α ⊕ γ) × β) : (β ⊕ γ) :=
begin
  success_if_fail { equiv_rw e at s {max_depth := 4} },
  equiv_rw e at s,
  exact s.1,
end

-- Test generating the actual equivalence using `equiv_rw_type`.
example {α β : Type} (e : α ≃ β) (b : β) : α × (ℕ ⊕ ℕ) :=
begin
  have e' : α × (ℕ ⊕ ℕ) ≃ _ := by equiv_rw_type e,
  apply e'.inv_fun,
  exact (b, sum.inl 0)
end

example {α β : Type} (e : α ≃ β) (P : α → Prop) (h : { a // P a }) : β :=
begin
  equiv_rw e at h,
  exact h.val,
end

example {α β : Type} (e : α ≃ β) (P : α → Prop) (h : ∀ a, P a) (b : β) : { a // P a } :=
begin
  equiv_rw e,
  use b,
  apply h,
end

example {α β : Type} (e : α ≃ β) (P : α → Prop) (h : ∀ a : α, P a) (b : β) : P (e.symm b) :=
begin
  equiv_rw e.symm at b,
  exact h b,
end

example {α β : Type} (e : α ≃ β) (P : α → Sort*) (h : Π a : α, P a) (b : β) : P (e.symm b) :=
begin
  -- this is a bit perverse, as `equiv_rw e.symm at b` is more natural,
  -- but this tests rewriting in the argument of a dependent function
  equiv_rw e at h,
  exact h _,
end

-- a poor example, rewriting in the base of a dependent pair
example {α β : Type} (P : α → Type) (h : Σ a, P a) (e : α ≃ β) : β :=
begin
  equiv_rw e at h,
  exact h.1
end

-- rewriting in the argument of a dependent function can't be done in one step
example {α β γ : Type} (e : α ≃ β) (P : α → Type*) (h : Π a : α, (P a) × (option α)) (b : β) :
  option β :=
begin
  equiv_rw e at h,
  have t := h b,
  equiv_rw e at t,
  exact t.2,
end

-- Demonstrate using `equiv_rw` to build new instances of `equiv_functor`
-- Observe that the next three declarations could easily be implemented by a tactic.

-- This has been automated in the `transport` branch,
-- so we won't attempt to write a deriver handler until we join with that.
def semigroup.map {α β : Type} (e : α ≃ β) : semigroup α → semigroup β :=
begin
  intro S,
  refine_struct { .. },
  -- transport data fields using `equiv_rw`
  { have mul := S.mul,
    equiv_rw e at mul,
    -- This `equiv_rw` performs the following steps:
    -- have e' := (equiv.arrow_congr' e (equiv.arrow_congr' e e)),
    -- have h := (e'.symm_apply_apply mul).symm,
    -- revert h,
    -- generalize : (e' mul) = mul',
    -- intro h,
    -- clear_dependent mul,
    -- rename mul' mul,
    exact mul, },
  -- transport axioms by simplifying, and applying the original axiom
  { intros, dsimp, simp, apply S.mul_assoc, }
end

example {α β : Type} (e : α ≃ β) (S : semigroup α) :
  (semigroup.map e S).mul =
    (equiv.arrow_congr' e (equiv.arrow_congr' e e)) has_mul.mul :=
rfl

example {α β : Type} (e : α ≃ β) (S : semigroup α) (x y : β) :
begin
  haveI := semigroup.map e S,
  exact x * y = e (e.symm x * e.symm y)
end :=
rfl

lemma semigroup.id_map (α : Type) : semigroup.map (equiv.refl α) = id :=
by { ext, refl, }

lemma semigroup.map_map {α β γ : Type} (e : α ≃ β) (f : β ≃ γ) :
  semigroup.map (e.trans f) = (semigroup.map f) ∘ (semigroup.map e) :=
by { ext, dsimp [semigroup.map], simp, }

-- TODO (after joining the `transport` branch) create a derive handler for this
instance : equiv_functor semigroup :=
{ map := λ α β e, semigroup.map e,
  map_refl' := semigroup.id_map,
  map_trans' := λ α β γ e f, semigroup.map_map e f, }

-- Verify that we can now use `equiv_rw` under `semigroup`:
example {α : Type} [I : semigroup α] {β : Type} (e : α ≃ β) : semigroup β :=
begin
  equiv_rw e at I,
  exact I,
end

-- Now we do `monoid`, to try out a structure with constants.

-- The constructions and proofs here are written as uniformly as possible.
-- This example is the blueprint for the `transport` tactic.

mk_simp_attribute transport_simps "simps useful inside `transport`"

attribute [transport_simps]
  eq_rec_constant
  cast_eq
  equiv.to_fun_as_coe
  equiv.arrow_congr'_apply
  equiv.symm_apply_apply
  equiv.apply_eq_iff_eq_symm_apply

def monoid.map {α β : Type} (e : α ≃ β) (S : monoid α) : monoid β :=
begin
  refine_struct { .. },
  { have mul := S.mul, equiv_rw e at mul, exact mul, },
  { try { unfold_projs },
    simp only with transport_simps,
    have mul_assoc := S.mul_assoc,
    equiv_rw e at mul_assoc,
    solve_by_elim, },
  { have one := S.one, equiv_rw e at one, exact one, },
  { try { unfold_projs },
    simp only with transport_simps,
    have one_mul := S.one_mul,
    equiv_rw e at one_mul,
    solve_by_elim, },
  { try { unfold_projs },
    simp only with transport_simps,
    have mul_one := S.mul_one,
    equiv_rw e at mul_one,
    solve_by_elim, },
  { have npow := S.npow, equiv_rw e at npow, exact npow, },
  { try { unfold_projs },
    simp only with transport_simps,
    have npow_zero' := S.npow_zero',
    equiv_rw e at npow_zero',
    solve_by_elim, },
  { try { unfold_projs },
    simp only with transport_simps,
    have npow_succ' := S.npow_succ',
    equiv_rw e at npow_succ',
    solve_by_elim, },
end

example {α β : Type} (e : α ≃ β) (S : monoid α) :
  (monoid.map e S).mul =
    (equiv.arrow_congr' e (equiv.arrow_congr' e e)) has_mul.mul :=
rfl

example {α β : Type} (e : α ≃ β) (S : monoid α) (x y : β) :
begin
  haveI := monoid.map e S,
  exact x * y = e (e.symm x * e.symm y)
end :=
rfl

example {α β : Type} (e : α ≃ β) (S : monoid α) :
begin
  haveI := monoid.map e S,
  exact (1 : β) = e (1 : α)
end :=
rfl

example
  {α : Type} {β : Type}
  (m : α → α → α)
  (e : α ≃ β) :
  β → β → β :=
begin
  equiv_rw e at m,
  exact m,
end

-- This used to fail because metavariables were getting stuck!
example
  {α : Type} {β : Type 2}
  (m : α → α → α)
  (e : α ≃ β) :
  β → β → β :=
begin
  equiv_rw e at m,
  exact m,
end

-- Rewriting multiple equivalences on target
example
  {α β χ δ : Type}
  (m : β → β → δ → δ)
  (e₁ : α ≃ β)
  (e₂ : χ ≃ δ) :
  α → α → χ → χ :=
begin
  equiv_rw [e₁, e₂],
  exact m,
end

-- Rewriting multiple equivalences on a hypothesis
example
  {α β χ δ : Type}
  (m : α → α → χ → χ)
  (e₁ : α ≃ β)
  (e₂ : χ ≃ δ) :
  β → β → δ → δ :=
begin
  equiv_rw [e₁, e₂] at m,
  exact m,
end

example
  {α β χ δ : Type}
  (m : β → β → β)
  (e : α ≃ β) :
  α → α → α :=
begin
  equiv_rw e at *,
  exact m,
end


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

/-!
# `star` on pi types

We put a `has_star` structure on pi types that operates elementwise, such that it describes the
complex conjugation of vectors.
-/

universes u v w
variable {I : Type u}     -- The indexing type
variable {f : I → Type v} -- The family of types already equipped with instances

namespace pi

instance [Π i, has_star (f i)] : has_star (Π i, f i) :=
{ star := λ x i, star (x i) }

@[simp] lemma star_apply [Π i, has_star (f i)] (x : Π i, f i) (i : I) : star x i = star (x i) := rfl

instance [Π i, has_involutive_star (f i)] : has_involutive_star (Π i, f i) :=
{ star_involutive := λ _, funext $ λ _, star_star _ }

instance [Π i, monoid (f i)] [Π i, star_monoid (f i)] : star_monoid (Π i, f i) :=
{ star_mul := λ _ _, funext $ λ _, star_mul _ _ }

instance [Π i, semiring (f i)] [Π i, star_ring (f i)] : star_ring (Π i, f i) :=
{ star_add := λ _ _, funext $ λ _, star_add _ _,
  ..(by apply_instance : star_monoid (Π i, f i)) }

instance {R : Type w}
  [comm_semiring R] [Π i, semiring (f i)] [Π i, algebra R (f i)]
  [star_ring R] [Π i, star_ring (f i)] [Π i, star_algebra R (f i)] :
  star_algebra R (Π i, f i) :=
{ star_smul := λ r x, funext $ λ _, star_smul _ _ }

end pi


/-
Copyright (c) 2021 OpenAI. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kunhao Zheng, Stanislas Polu, David Renshaw, OpenAI GPT-f
-/
import mathzoo.imports.miniF2F

open_locale nat rat real big_operators topological_space

theorem mathd_algebra_171
  (f : ℝ → ℝ)
  (h₀ : ∀x, f x = 5 * x + 4) :
  f 1 = 9 :=
begin
  rw h₀,
  linarith,
end


-- Pruebas de P → (Q → P)
-- ======================

-- ----------------------------------------------------
-- Ej. 1. (p. 13) Demostrar
--    P → (Q → P)
-- ----------------------------------------------------

import tactic

variables (P Q : Prop)

-- 1ª demostración
example : P → (Q → P) :=
assume h1 : P,
show Q → P, from
  ( assume h2 : Q,
    show P, from h1)

-- 2ª demostración
example : P → (Q → P) :=
assume (h1 : P),
show Q → P, from
  ( assume h2 : Q, h1)

-- 3ª demostración
example : P → (Q → P) :=
assume (h1 : P),
show Q → P, from
  (λ h2, h1)

-- 4ª demostración
example : P → (Q → P) :=
assume (h1 : P), (λ h2, h1)

-- 5ª demostración
example : P → (Q → P) :=
λ h1, λ h2, h1

-- 6ª demostración
example : P → (Q → P) :=
λ h1 h2, h1

-- 7ª demostración
example : P → (Q → P) :=
λ h _, h

-- 8ª demostración
example : P → (Q → P) :=
-- by library_search
imp_intro

-- 9ª demostración
example : P → (Q → P) :=
begin
  intro h1,
  intro h2,
  exact h1,
end

-- 10ª demostración
example : P → (Q → P) :=
begin
  intros h1 h2,
  exact h1,
end

-- 11ª demostración
example : P → (Q → P) :=
λ h1 h2, h1

-- 12ª demostración
example : P → (Q → P) :=
-- by hint
by tauto

-- 13ª demostración
example : P → (Q → P) :=
by finish


/-
Copyright (c) 2019 Zhouhang Zhou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Zhouhang Zhou
-/
import algebra.char_p.invertible
import order.filter.at_top_bot
import tactic.linarith
import tactic.field_simp
import tactic.linear_combination

/-!
# Quadratic discriminants and roots of a quadratic

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

This file defines the discriminant of a quadratic and gives the solution to a quadratic equation.

## Main definition

- `discrim a b c`: the discriminant of a quadratic `a * x * x + b * x + c` is `b * b - 4 * a * c`.

## Main statements

- `quadratic_eq_zero_iff`: roots of a quadratic can be written as
  `(-b + s) / (2 * a)` or `(-b - s) / (2 * a)`, where `s` is a square root of the discriminant.
- `quadratic_ne_zero_of_discrim_ne_sq`: if the discriminant has no square root,
  then the corresponding quadratic has no root.
- `discrim_le_zero`: if a quadratic is always non-negative, then its discriminant is non-positive.
- `discrim_le_zero_of_nonpos`, `discrim_lt_zero`, `discrim_lt_zero_of_neg`: versions of this
  statement with other inequalities.

## Tags

polynomial, quadratic, discriminant, root
-/

open filter

section ring
variables {R : Type*}

/-- Discriminant of a quadratic -/
def discrim [ring R] (a b c : R) : R := b^2 - 4 * a * c

@[simp] lemma discrim_neg [ring R] (a b c : R) : discrim (-a) (-b) (-c) = discrim a b c :=
by simp [discrim]

variables [comm_ring R] {a b c : R}

lemma discrim_eq_sq_of_quadratic_eq_zero {x : R} (h : a * x * x + b * x + c = 0) :
  discrim a b c = (2 * a * x + b) ^ 2 :=
begin
  rw [discrim],
  linear_combination -4 * a * h
end

/--
A quadratic has roots if and only if its discriminant equals some square.
-/
lemma quadratic_eq_zero_iff_discrim_eq_sq [ne_zero (2 : R)] [no_zero_divisors R]
  (ha : a ≠ 0) {x : R} :
  a * x * x + b * x + c = 0 ↔ discrim a b c = (2 * a * x + b) ^ 2 :=
begin
  refine ⟨discrim_eq_sq_of_quadratic_eq_zero, λ h, _⟩,
  rw [discrim] at h,
  have ha : 2 * 2 * a ≠ 0 := mul_ne_zero (mul_ne_zero (ne_zero.ne _) (ne_zero.ne _)) ha,
  apply mul_left_cancel₀ ha,
  linear_combination -h
end

/-- A quadratic has no root if its discriminant has no square root. -/
lemma quadratic_ne_zero_of_discrim_ne_sq (h : ∀ s : R, discrim a b c ≠ s^2) (x : R) :
  a * x * x + b * x + c ≠ 0 :=
mt discrim_eq_sq_of_quadratic_eq_zero $ h _

end ring

section field
variables {K : Type*} [field K] [ne_zero (2 : K)] {a b c x : K}

/-- Roots of a quadratic equation. -/
lemma quadratic_eq_zero_iff (ha : a ≠ 0) {s : K} (h : discrim a b c = s * s) (x : K) :
  a * x * x + b * x + c = 0 ↔ x = (-b + s) / (2 * a) ∨ x = (-b - s) / (2 * a) :=
begin
  rw [quadratic_eq_zero_iff_discrim_eq_sq ha, h, sq, mul_self_eq_mul_self_iff],
  field_simp,
  apply or_congr,
  { split; intro h'; linear_combination -h' },
  { split; intro h'; linear_combination h' },
end

/-- A quadratic has roots if its discriminant has square roots -/
lemma exists_quadratic_eq_zero (ha : a ≠ 0) (h : ∃ s, discrim a b c = s * s) :
  ∃ x, a * x * x + b * x + c = 0 :=
begin
  rcases h with ⟨s, hs⟩,
  use (-b + s) / (2 * a),
  rw quadratic_eq_zero_iff ha hs,
  simp
end

/-- Root of a quadratic when its discriminant equals zero -/
lemma quadratic_eq_zero_iff_of_discrim_eq_zero (ha : a ≠ 0) (h : discrim a b c = 0) (x : K) :
  a * x * x + b * x + c = 0 ↔ x = -b / (2 * a) :=
begin
  have : discrim a b c = 0 * 0, by rw [h, mul_zero],
  rw [quadratic_eq_zero_iff ha this, add_zero, sub_zero, or_self]
end

end field

section linear_ordered_field
variables {K : Type*} [linear_ordered_field K] {a b c : K}

/-- If a polynomial of degree 2 is always nonnegative, then its discriminant is nonpositive. -/
lemma discrim_le_zero (h : ∀ x : K, 0 ≤ a * x * x + b * x + c) : discrim a b c ≤ 0 :=
begin
  rw [discrim, sq],
  obtain ha|rfl|ha : a < 0 ∨ a = 0 ∨ 0 < a := lt_trichotomy a 0,
  -- if a < 0
  { have : tendsto (λ x, (a * x + b) * x + c) at_top at_bot :=
     tendsto_at_bot_add_const_right _ c ((tendsto_at_bot_add_const_right _ b
       (tendsto_id.neg_const_mul_at_top ha)).at_bot_mul_at_top tendsto_id),
    rcases (this.eventually (eventually_lt_at_bot 0)).exists with ⟨x, hx⟩,
    exact false.elim ((h x).not_lt $ by rwa ← add_mul) },
  -- if a = 0
  { rcases eq_or_ne b 0 with (rfl|hb),
    { simp },
    { have := h ((-c - 1) / b), rw [mul_div_cancel' _ hb] at this, linarith } },
  -- if a > 0
  { have ha' : 0 ≤ 4 * a := mul_nonneg zero_le_four ha.le,
    have := h (-b / (2 * a)),
    convert neg_nonpos.2 (mul_nonneg ha' (h (-b / (2 * a)))),
    field_simp [ha.ne'],
    ring }
end

lemma discrim_le_zero_of_nonpos (h : ∀ x : K, a * x * x + b * x + c ≤ 0) : discrim a b c ≤ 0 :=
discrim_neg a b c ▸ discrim_le_zero (by simpa only [neg_mul, ← neg_add, neg_nonneg])

/--
If a polynomial of degree 2 is always positive, then its discriminant is negative,
at least when the coefficient of the quadratic term is nonzero.
-/
lemma discrim_lt_zero (ha : a ≠ 0) (h : ∀ x : K, 0 < a * x * x + b * x + c) : discrim a b c < 0 :=
begin
  have : ∀ x : K, 0 ≤ a*x*x + b*x + c := assume x, le_of_lt (h x),
  refine lt_of_le_of_ne (discrim_le_zero this) _,
  assume h',
  have := h (-b / (2 * a)),
  have : a * (-b / (2 * a)) * (-b / (2 * a)) + b * (-b / (2 * a)) + c = 0,
  { rw [quadratic_eq_zero_iff_of_discrim_eq_zero ha h' (-b / (2 * a))] },
  linarith
end

lemma discrim_lt_zero_of_neg (ha : a ≠ 0) (h : ∀ x : K, a * x * x + b * x + c < 0) :
  discrim a b c < 0 :=
discrim_neg a b c ▸ discrim_lt_zero (neg_ne_zero.2 ha) (by simpa only [neg_mul, ← neg_add, neg_pos])

end linear_ordered_field


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.linear_algebra.basic
import Mathlib.algebra.ring.ulift
import Mathlib.PostPort

universes u v u_1 w

namespace Mathlib

/-!
# `ulift` instances for module and multiplicative actions

This file defines instances for module, mul_action and related structures on `ulift` types.

(Recall `ulift α` is just a "copy" of a type `α` in a higher universe.)

We also provide `ulift.semimodule_equiv : ulift M ≃ₗ[R] M`.

-/

namespace ulift

protected instance has_scalar {R : Type u} {M : Type v} [has_scalar R M] : has_scalar (ulift R) M :=
  has_scalar.mk fun (s : ulift R) (x : M) => down s • x

@[simp] theorem smul_down {R : Type u} {M : Type v} [has_scalar R M] (s : ulift R) (x : M) :
    s • x = down s • x :=
  rfl

protected instance has_scalar' {R : Type u} {M : Type v} [has_scalar R M] :
    has_scalar R (ulift M) :=
  has_scalar.mk fun (s : R) (x : ulift M) => up (s • down x)

@[simp] theorem smul_down' {R : Type u} {M : Type v} [has_scalar R M] (s : R) (x : ulift M) :
    down (s • x) = s • down x :=
  rfl

protected instance is_scalar_tower {R : Type u} {M : Type v} {N : Type w} [has_scalar R M]
    [has_scalar M N] [has_scalar R N] [is_scalar_tower R M N] : is_scalar_tower (ulift R) M N :=
  is_scalar_tower.mk
    fun (x : ulift R) (y : M) (z : N) =>
      (fun (this : (down x • y) • z = down x • y • z) => this) (smul_assoc (down x) y z)

protected instance is_scalar_tower' {R : Type u} {M : Type v} {N : Type w} [has_scalar R M]
    [has_scalar M N] [has_scalar R N] [is_scalar_tower R M N] : is_scalar_tower R (ulift M) N :=
  is_scalar_tower.mk
    fun (x : R) (y : ulift M) (z : N) =>
      (fun (this : (x • down y) • z = x • down y • z) => this) (smul_assoc x (down y) z)

protected instance is_scalar_tower'' {R : Type u} {M : Type v} {N : Type w} [has_scalar R M]
    [has_scalar M N] [has_scalar R N] [is_scalar_tower R M N] : is_scalar_tower R M (ulift N) :=
  is_scalar_tower.mk
    fun (x : R) (y : M) (z : ulift N) =>
      (fun (this : up ((x • y) • down z) = up (x • y • down z)) => this)
        (eq.mpr
          (id
            (Eq._oldrec (Eq.refl (up ((x • y) • down z) = up (x • y • down z)))
              (smul_assoc x y (down z))))
          (Eq.refl (up (x • y • down z))))

protected instance mul_action {R : Type u} {M : Type v} [monoid R] [mul_action R M] :
    mul_action (ulift R) M :=
  mul_action.mk sorry sorry

protected instance mul_action' {R : Type u} {M : Type v} [monoid R] [mul_action R M] :
    mul_action R (ulift M) :=
  mul_action.mk sorry sorry

protected instance distrib_mul_action {R : Type u} {M : Type v} [monoid R] [add_monoid M]
    [distrib_mul_action R M] : distrib_mul_action (ulift R) M :=
  distrib_mul_action.mk sorry sorry

protected instance distrib_mul_action' {R : Type u} {M : Type v} [monoid R] [add_monoid M]
    [distrib_mul_action R M] : distrib_mul_action R (ulift M) :=
  distrib_mul_action.mk sorry sorry

protected instance semimodule {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    [semimodule R M] : semimodule (ulift R) M :=
  semimodule.mk sorry sorry

protected instance semimodule' {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M]
    [semimodule R M] : semimodule R (ulift M) :=
  semimodule.mk sorry sorry

/--
The `R`-linear equivalence between `ulift M` and `M`.
-/
def semimodule_equiv {R : Type u} {M : Type v} [semiring R] [add_comm_monoid M] [semimodule R M] :
    linear_equiv R (ulift M) M :=
  linear_equiv.mk down sorry sorry up sorry sorry

end Mathlib