import homotopy_theory.formal.cylinder.homotopy
import homotopy_theory.formal.cylinder.sdr
import .definitions
import .homotopy_lemmas
import .homotopy_equivalences

/-

Dold's theorem: Suppose j : A → X and j' : A → X' are cofibrations and
f : X → X' is a homotopy equivalence with f ∘ j = j'. Then f is a
homotopy equivalence under A.

-/

universes v u

open category_theory
open category_theory.category
local notation f ` ∘ `:80 g:80 := g ≫ f

namespace homotopy_theory.cofibrations
section C
open category_theory.has_initial_object
open homotopy_theory.cylinder
open precofibration_category
open I_category

parameters {C : Type u} [category.{v} C] [has_initial_object.{v} C]
  [has_coproducts.{v} C] [I_category.{v} C]

-- [Kamps & Porter, Lemma I.6.4]. Apparently, we already did most of
-- the hard work.
lemma dold_lemma {a x : C} {j : a ⟶ x} (hj : is_cof j) {g : x ⟶ x} (hg : g ∘ j = j)
  (h : g ≃ 𝟙 x) : ∃ g', g' ∘ j = j ∧ g' ∘ g ≃ 𝟙 x rel j :=
let ⟨φ⟩ := h,
    φ' := φ.congr_right j,
    ⟨ψ, hψ₁, hψ₂⟩ := hep_cof j hj 0 x (𝟙 x) φ'.H (by rw [φ'.Hi₀, hg]; simp),
    g' := ψ ∘ i 1 @> x,
    ψh : homotopy (𝟙 x) g' := { H := ψ, Hi₀ := hψ₁, Hi₁ := rfl } in
have g' ∘ j = j, by dsimp [g']; rw [i_nat_assoc, hψ₂, φ'.Hi₁]; simp,
suffices H : g' ∘ g ≃ 𝟙 x rel j, from ⟨g', this, H⟩,
let ψhg : homotopy g (g' ∘ g) :=
  @eq.rec_on (x ⟶ x) (𝟙 x ∘ g) (λ f, homotopy f (g' ∘ g)) g (by simp)
    (ψh.congr_right g) in
have ψhg.H ∘ I &> j = φ'.H, begin
  convert hψ₂ using 1, rw homotopy.eq_rec_on_left,
  change ψ ∘ I &> g ∘ I &> j = ψ ∘ I &> j,
  rw [←assoc, ←I.map_comp, hg]
end,
equiv_private.f₁_f₂ j hj homotopy.refl_is_rel 0 this rfl

lemma dold_lemma' {a x x' : C} {j : a ⟶ x} (hj : is_cof j) (f : x ⟶ x') (r : x' ⟶ x)
  (hr : r ∘ f ∘ j = j) (h : r ∘ f ≃ 𝟙 x) : ∃ r', r' ∘ f ∘ j = j ∧ r' ∘ f ≃ 𝟙 x rel j :=
let ⟨g', hg'₁, hg'₂⟩ := dold_lemma hj hr h in
⟨g' ∘ r,
 calc
  g' ∘ r ∘ f ∘ j = g' ∘ (r ∘ f ∘ j) : by simp
  ...            = j                : by rw [hr, hg'₁],
 by convert hg'₂ using 1; simp⟩

-- Ugh! We'd like to use `calc` to compose homotopies rel j', but
-- homotopic_rel.trans has an extra `is_cof j` argument which we have
-- no way to provide explicitly. So, we locally arrange for the
-- argument to be provided by the type class system.
local attribute [class] is_cof

@[trans] private lemma homotopic_rel.trans' {a b x : C} {j : a ⟶ b} [hj : is_cof j]
  {f₀ f₁ f₂ : b ⟶ x} (h₁ : f₀ ≃ f₁ rel j) (h₂ : f₁ ≃ f₂ rel j) : f₀ ≃ f₂ rel j :=
homotopic_rel.trans hj h₁ h₂

-- Why is this necessary? doesn't work without `local`
local notation f₀ ` ≃ `:50 f₁:50 := homotopic f₀ f₁

-- [Kamps & Porter, Theorem I.6.3]
lemma dold_theorem {a x x' : C} {j : a ⟶ x} (hj : is_cof j) {j' : a ⟶ x'} (hj' : is_cof j')
  {f : x ⟶ x'} (hf : f ∘ j = j') (hef : homotopy_equivalence f) :
  ∃ h : x' ⟶ x, h ∘ j' = j ∧ h ∘ f ≃ 𝟙 _ rel j ∧ f ∘ h ≃ 𝟙 _ rel j' :=
let ⟨f', hf'₁, hf'₂⟩ := homotopy_equivalence_iff.mp hef in
have f' ∘ j' ≃ j, from calc
  f' ∘ j' = f' ∘ f ∘ j : by rw ←hf; simp
  ...     ≃ j          : by convert hf'₁.congr_right j; simp,
let ⟨H⟩ := this,
    ⟨H', hH'₁, hH'₂⟩ := hep_cof j' hj' 0 x f' H.H H.Hi₀.symm,
    f'' := H' ∘ i 1 @> x' in
have f' ≃ f'', from ⟨⟨H', hH'₁, rfl⟩⟩,
have f'' ∘ j' = j, by dsimp [f'']; rw [i_nat_assoc, hH'₂, H.Hi₁],
let ⟨h, hh₁, hh₂⟩ :=
      dold_lemma' hj f f'' (by rw [←assoc, hf, this]) $ calc
        f'' ∘ f ≃ f' ∘ f : ‹f' ≃ f''›.symm.congr_right f
        ...     ≃ 𝟙 x    : hf'₁ in
have f ∘ h ≃ 𝟙 x', from calc
  f ∘ h ≃ f ∘ h ∘ (f ∘ f')  : by convert hf'₂.symm.congr_left (f ∘ h) using 1; simp
  ...   ≃ f ∘ h ∘ (f ∘ f'') : (‹f' ≃ f''›.congr_left f).congr_left (f ∘ h)
  ...   = f ∘ (h ∘ f) ∘ f'' : by simp
  ...   ≃ f ∘ 𝟙 x ∘ f''     : (hh₂.forget_rel.congr_left f).congr_right f''
  ...   ≃ f ∘ f'            : by convert ‹f' ≃ f''›.symm.congr_left f; simp
  ...   ≃ 𝟙 x'              : hf'₂,
have fhj' : f ∘ h ∘ j' = j', by rw [←hf, ←assoc]; congr; simp [hh₁],
let ⟨k, hk₁, hk₂⟩ := dold_lemma' hj' h f fhj' this in
have hk₂' : k ∘ h ≃ 𝟙 x' rel f ∘ h ∘ j', by convert hk₂; exact fhj',
have hh₂' : h ∘ f ≃ 𝟙 x rel h ∘ j', by convert hh₂; rw [←hf]; simp [hh₁],
⟨h, by rw [←hf]; simp [hh₁], hh₂, calc
  f ∘ h ≃ (k ∘ h) ∘ (f ∘ h) rel j'  : by convert (hk₂'.congr_right (f ∘ h)).symm hj' using 1; simp
  ...   = k ∘ (h ∘ f) ∘ h           : by simp
  ...   ≃ k ∘ (𝟙 x) ∘ h     rel j'  : by convert (hh₂'.congr_left k).congr_right h using 1; refl
  ...   = k ∘ h                     : by simp
  ...   ≃ 𝟙 x'              rel j'  : hk₂⟩

-- [Kamps & Porter, Theorem I.6.9]. Apply Dold's theorem to j itself.
lemma heq_iff_sdr_inclusion {a x : C} {j : a ⟶ x} (hj : is_cof j) :
  homotopy_equivalence j ↔ is_sdr_inclusion j :=
iff.intro
  (assume hf,
    let ⟨h, hh₁, hh₂, hh₃⟩ := dold_theorem (cof_id a) hj (by simp) hf in
    ⟨⟨h, hh₁, hh₃⟩⟩)
  (assume ⟨⟨r, h, H⟩⟩, homotopy_equivalence_iff.mpr
    ⟨r, by convert homotopic.refl (𝟙 a), H.forget_rel⟩)

lemma pushout_is_acof {a x a' x' : C} {j : a ⟶ x} {f : a ⟶ a'} {f' : x ⟶ x'} {j' : a' ⟶ x'}
  (po : Is_pushout j f f' j') (hj : is_cof j) (hej : homotopy_equivalence j) :
  homotopy_equivalence j' :=
have is_cof j', from pushout_is_cof po hj,
(heq_iff_sdr_inclusion this).mpr $
pushout_of_sdr_inclusion po (I_preserves_pushout_by_cof hj po) $
(heq_iff_sdr_inclusion hj).mp hej

end C
end homotopy_theory.cofibrations


import ..lovelib

/-! # LoVe Demo 8: Operational Semantics

In this and the next two lectures, we will see how to use Lean to specify the
syntax and semantics of programming languages and to reason about the
semantics. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/-! ## Formal Semantics

A formal semantics helps specify and reason about the programming language
itself, and about individual programs.

It can form the basis of verified compilers, interpreters, verifiers, static
analyzers, type checkers, etc. Without formal proofs, these tools are
**almost always wrong**.

In this area, proof assistants are widely used. Every year, about 10-20% of POPL
papers are partially or totally formalized. Reasons for this success:

* Little machinery (background libraries, tactics) is needed to get started,
  beyond inductive types and predicates and recursive functions.

* The proofs tend to have lots of cases, which is a good match for computers.

* Proof assistants keep track of what needs to be changed when as extend the
  programming language with more features.

Case in point: WebAssembly. To quote Conrad Watt (with some abbreviations):

    We have produced a full Isabelle mechanisation of the core execution
    semantics and type system of the WebAssembly language. To complete this
    proof, **several deficiencies** in the official WebAssembly specification,
    uncovered by our proof and modelling work, needed to be corrected. In some
    cases, these meant that the type system was **originally unsound**.

    We have maintained a constructive dialogue with the working group,
    verifying new features as they are added. In particular, the mechanism by
    which a WebAssembly implementation interfaces with its host environment was
    not formally specified in the working group's original paper. Extending our
    mechanisation to model this feature revealed a deficiency in the WebAssembly
    specification that **sabotaged the soundness** of the type system.

## A Minimalistic Imperative Language

A state `s` is a function from variable names to values (`string → ℕ`).

__WHILE__ is a minimalistic imperative language with the following grammar:

    S  ::=  skip                 -- no-op
         |  x := a               -- assignment
         |  S ; S                -- sequential composition
         |  if b then S else S   -- conditional statement
         |  while b do S         -- while loop

where `S` stands for a statement (also called command or program), `x` for a
variable, `a` for an arithmetic expression, and `b` for a Boolean expression. -/

#print state

inductive stmt : Type
| skip   : stmt
| assign : string → (state → ℕ) → stmt
| seq    : stmt → stmt → stmt
| ite    : (state → Prop) → stmt → stmt → stmt
| while  : (state → Prop) → stmt → stmt

infixr ` ;; ` : 90 := stmt.seq

#check λ s : state, s "y" + 2 * s "z"

/-! In our grammar, we deliberately leave the syntax of arithmetic and Boolean
expressions unspecified. In Lean, we have the choice:

* We could use a type such as `aexp` from lecture 1 and similarly for Boolean
  expressions.

* We could decide that an arithmetic expression is simply a function from
  states to natural numbers (`state → ℕ`) and a Boolean expression is a
  predicate (`state → Prop` or `state → bool`).

This corresponds to the difference between deep and shallow embeddings:

* A __deep embedding__ of some syntax (expression, formula, program, etc.)
  consists of an abstract syntax tree specified in the proof assistant
  (e.g., `aexp`) with a semantics (e.g., `eval`).

* In contrast, a __shallow embedding__ simply reuses the corresponding
  mechanisms from the logic (e.g., λ-terms, functions and predicate types).

A deep embedding allows us to reason about the syntax (and its semantics). A
shallow embedding is more lightweight, because we can use it directly, without
having to define a semantics.

We will use a deep embedding of programs (which we find interesting), and
shallow embeddings of assignments and Boolean expressions (which we find
boring). -/

def silly_loop : stmt :=
stmt.while (λs, s "x" > s "y")
  (stmt.skip ;; stmt.assign "x" (λs, s "x" - 1))

/-! ## Big-Step Semantics

An __operational semantics__ corresponds to an idealized interpreter (specified
in a Prolog-like language). Two main variants:

* big-step semantics;

* small-step semantics.

In a __big-step semantics__ (also called __natural semantics__), judgments have
the form `(S, s) ⟹ t`:

    Starting in a state `s`, executing `S` terminates in the state `t`.

Example:

    `(x := x + y; y := 0, [x ↦ 3, y ↦ 5]) ⟹ [x ↦ 8, y ↦ 0]`

Derivation rules:

    ——————————————— Skip
    (skip, s) ⟹ s

    ——————————————————————————— Asn
    (x := a, s) ⟹ s[x ↦ s(a)]

    (S, s) ⟹ t   (T, t) ⟹ u
    ——————————————————————————— Seq
    (S; T, s) ⟹ u

    (S, s) ⟹ t
    ————————————————————————————— If-True   if s(b) is true
    (if b then S else T, s) ⟹ t

    (T, s) ⟹ t
    ————————————————————————————— If-False   if s(b) is false
    (if b then S else T, s) ⟹ t

    (S, s) ⟹ t   (while b do S, t) ⟹ u
    —————————————————————————————————————— While-True   if s(b) is true
    (while b do S, s) ⟹ u

    ————————————————————————— While-False   if s(b) is false
    (while b do S, s) ⟹ s

Above, `s(e)` denotes the value of expression `e` in state `s`.

In Lean, the judgment corresponds to an inductive predicate, and the derivation
rules correspond to the predicate's introduction rules. Using an inductive
predicate as opposed to a recursive function allows us to cope with
nontermination (e.g., a diverging `while`) and nondeterminism (e.g.,
multithreading). -/

inductive big_step : stmt × state → state → Prop
| skip {s} :
  big_step (stmt.skip, s) s
| assign {x a s} :
  big_step (stmt.assign x a, s) (s{x ↦ a s})
| seq {S T s t u} (hS : big_step (S, s) t)
    (hT : big_step (T, t) u) :
  big_step (S ;; T, s) u
| ite_true {b : state → Prop} {S T s t} (hcond : b s)
    (hbody : big_step (S, s) t) :
  big_step (stmt.ite b S T, s) t
| ite_false {b : state → Prop} {S T s t} (hcond : ¬ b s)
    (hbody : big_step (T, s) t) :
  big_step (stmt.ite b S T, s) t
| while_true {b : state → Prop} {S s t u} (hcond : b s)
    (hbody : big_step (S, s) t)
    (hrest : big_step (stmt.while b S, t) u) :
  big_step (stmt.while b S, s) u
| while_false {b : state → Prop} {S s} (hcond : ¬ b s) :
  big_step (stmt.while b S, s) s

infix ` ⟹ ` : 110 := big_step

lemma silly_loop_from_1_big_step :
  (silly_loop, (λ_, 0){"x" ↦ 1}) ⟹ (λ_, 0) :=
begin
  rw silly_loop,
  apply big_step.while_true,
  { simp },
  { apply big_step.seq,
    { apply big_step.skip },
    { apply big_step.assign } },
  { simp,
    apply big_step.while_false,
    linarith }
end

/-! ## Properties of the Big-Step Semantics

Equipped with a big-step semantics, we can

* prove properties of the programming language, such as **equivalence proofs**
  between programs and **determinism**;

* reason about **concrete programs**, proving theorems relating final states `t`
  with initial states `s`. -/

lemma big_step_deterministic {S s l r} (hl : (S, s) ⟹ l)
    (hr : (S, s) ⟹ r) :
  l = r :=
begin
  induction' hl,
  case skip {
    cases' hr,
    refl },
  case assign {
    cases' hr,
    refl },
  case seq : S T s t l hS hT ihS ihT {
    cases' hr with _ _ _ _ _ _ _ t' _ hS' hT',
    cases' ihS hS',
    cases' ihT hT',
    refl },
  case ite_true : b S T s t hb hS ih {
    cases' hr,
    { apply ih hr },
    { cc } },
  case ite_false : b S T s t hb hT ih {
    cases' hr,
    { cc },
    { apply ih hr } },
  case while_true : b S s t u hb hS hw ihS ihw {
    cases' hr,
    { cases' ihS hr,
      cases' ihw hr_1,
      refl },
    { cc } },
  case while_false {
    cases' hr,
    { cc },
    { refl } }
end

lemma big_step_terminates {S s} :
  ∃t, (S, s) ⟹ t :=
sorry   -- unprovable

lemma big_step_doesnt_terminate {S s t} :
  ¬ (stmt.while (λ_, true) S, s) ⟹ t :=
begin
  intro hw,
  induction' hw,
  case while_true {
    assumption },
  case while_false {
    cc }
end

/-! We can define inversion rules about the big-step semantics: -/

@[simp] lemma big_step_skip_iff {s t} :
  (stmt.skip, s) ⟹ t ↔ t = s :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    refl },
  { intro h,
    rw h,
    exact big_step.skip }
end

@[simp] lemma big_step_assign_iff {x a s t} :
  (stmt.assign x a, s) ⟹ t ↔ t = s{x ↦ a s} :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    refl },
  { intro h,
    rw h,
    exact big_step.assign }
end

@[simp] lemma big_step_seq_iff {S T s t} :
  (S ;; T, s) ⟹ t ↔ (∃u, (S, s) ⟹ u ∧ (T, u) ⟹ t) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    apply exists.intro,
    apply and.intro; assumption },
  { intro h,
    cases' h,
    cases' h,
    apply big_step.seq; assumption }
end

@[simp] lemma big_step_ite_iff {b S T s t} :
  (stmt.ite b S T, s) ⟹ t ↔
  (b s ∧ (S, s) ⟹ t) ∨ (¬ b s ∧ (T, s) ⟹ t) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    { apply or.intro_left,
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases' h; cases' h,
    { apply big_step.ite_true; assumption },
    { apply big_step.ite_false; assumption } }
end

lemma big_step_while_iff {b S s u} :
  (stmt.while b S, s) ⟹ u ↔
  (∃t, b s ∧ (S, s) ⟹ t ∧ (stmt.while b S, t) ⟹ u)
  ∨ (¬ b s ∧ u = s) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    { apply or.intro_left,
      apply exists.intro t,
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases' h,
    case inl {
      cases' h with t h,
      cases' h with hb h,
      cases' h with hS hwhile,
      exact big_step.while_true hb hS hwhile },
    case inr {
      cases' h with hb hus,
      rw hus,
      exact big_step.while_false hb } }
end

lemma big_step_while_true_iff {b : state → Prop} {S s u}
    (hcond : b s) :
  (stmt.while b S, s) ⟹ u ↔
  (∃t, (S, s) ⟹ t ∧ (stmt.while b S, t) ⟹ u) :=
by rw big_step_while_iff; simp [hcond]

@[simp] lemma big_step_while_false_iff {b : state → Prop}
    {S s t} (hcond : ¬ b s) :
  (stmt.while b S, s) ⟹ t ↔ t = s :=
by rw big_step_while_iff; simp [hcond]

/-! ## Small-Step Semantics

A big-step semantics

* does not let us reason about intermediate states;

* does not let us express nontermination or interleaving (for multithreading).

__Small-step semantics__ (also called __structural operational semantics__)
solve the above issues.

A judgment has the form `(S, s) ⇒ (T, t)`:

    Starting in a state `s`, executing one step of `S` leaves us in the
    state `t`, with the program `T` remaining to be executed.

An execution is a finite or infinite chain `(S₀, s₀) ⇒ (S₁, s₁) ⇒ …`.

A pair `(S, s)` is called a __configuration__. It is __final__ if no transition
of the form `(S, s) ⇒ _` is possible.

Example:

      `(x := x + y; y := 0, [x ↦ 3, y ↦ 5])`
    `⇒ (skip; y := 0,       [x ↦ 8, y ↦ 5])`
    `⇒ (y := 0,             [x ↦ 8, y ↦ 5])`
    `⇒ (skip,               [x ↦ 8, y ↦ 0])`

Derivation rules:

    ————————————————————————————————— Asn
    (x := a, s) ⇒ (skip, s[x ↦ s(a)])

    (S, s) ⇒ (S', s')
    ———-————————————————————— Seq-Step
    (S ; T, s) ⇒ (S' ; T, s')

    —————————————————————— Seq-Skip
    (skip ; S, s) ⇒ (S, s)

    ———————————————————————————————— If-True   if s(b) is true
    (if b then S else T, s) ⇒ (S, s)

    ———————————————————————————————— If-False   if s(b) is false
    (if b then S else T, s) ⇒ (T, s)

    ——————————————————————————————————————————————————————————————— While
    (while b do S, s) ⇒ (if b then (S ; while b do S) else skip, s)

There is no rule for `skip` (why?). -/

inductive small_step : stmt × state → stmt × state → Prop
| assign {x a s} :
  small_step (stmt.assign x a, s) (stmt.skip, s{x ↦ a s})
| seq_step {S S' T s s'} (hS : small_step (S, s) (S', s')) :
  small_step (S ;; T, s) (S' ;; T, s')
| seq_skip {T s} :
  small_step (stmt.skip ;; T, s) (T, s)
| ite_true {b : state → Prop} {S T s} (hcond : b s) :
  small_step (stmt.ite b S T, s) (S, s)
| ite_false {b : state → Prop} {S T s} (hcond : ¬ b s) :
  small_step (stmt.ite b S T, s) (T, s)
| while {b : state → Prop} {S s} :
  small_step (stmt.while b S, s)
    (stmt.ite b (S ;; stmt.while b S) stmt.skip, s)

infixr ` ⇒ ` := small_step
infixr ` ⇒* ` : 100 := star small_step

lemma silly_loop_from_1_small_step :
  (silly_loop, (λ_, 0){"x" ↦ 1}) ⇒*
  (stmt.skip, ((λ_, 0) : state)) :=
begin
  rw silly_loop,
  apply star.head,
  { apply small_step.while },
  { apply star.head,
    { apply small_step.ite_true,
      simp },
    { apply star.head,
      { apply small_step.seq_step,
        apply small_step.seq_skip },
      { apply star.head,
        { apply small_step.seq_step,
          apply small_step.assign },
        { apply star.head,
          { apply small_step.seq_skip },
          { apply star.head,
            { apply small_step.while },
            { apply star.head,
              { apply small_step.ite_false,
                simp },
              { simp } } } } } } }
end

/-! Equipped with a small-step semantics, we can **define** a big-step
semantics:

    `(S, s) ⟹ t` if and only if `(S, s) ⇒* (skip, t)`

where `r*` denotes the reflexive transitive closure of a relation `r`.

Alternatively, if we have already defined a big-step semantics, we can **prove**
the above equivalence theorem to validate our definitions.

The main disadvantage of small-step semantics is that we now have two relations,
`⇒` and `⇒*`, and reasoning tends to be more complicated.

## Properties of the Small-Step Semantics

We can prove that a configuration `(S, s)` is final if and only if `S = skip`.
This ensures that we have not forgotten a derivation rule. -/

lemma small_step_final (S s) :
  (¬ ∃T t, (S, s) ⇒ (T, t)) ↔ S = stmt.skip :=
begin
  induction' S,
  case skip {
    simp,
    intros T t hstep,
    cases' hstep },
  case assign : x a {
    simp,
    apply exists.intro stmt.skip,
    apply exists.intro (s{x ↦ a s}),
    exact small_step.assign },
  case seq : S T ihS ihT {
    simp,
    cases' classical.em (S = stmt.skip),
    case inl {
      rw h,
      apply exists.intro T,
      apply exists.intro s,
      exact small_step.seq_skip },
    case inr {
      simp [h, auto.not_forall_eq, auto.not_not_eq] at ihS,
      cases' ihS s with S' hS',
      cases' hS' with s' hs',
      apply exists.intro (S' ;; T),
      apply exists.intro s',
      exact small_step.seq_step hs' } },
  case ite : b S T ihS ihT {
    simp,
    cases' classical.em (b s),
    case inl {
      apply exists.intro S,
      apply exists.intro s,
      exact small_step.ite_true h },
    case inr {
      apply exists.intro T,
      apply exists.intro s,
      exact small_step.ite_false h } },
  case while : b S ih {
    simp,
    apply exists.intro (stmt.ite b (S ;; stmt.while b S) stmt.skip),
    apply exists.intro s,
    exact small_step.while }
end

lemma small_step_deterministic {S s Ll Rr}
    (hl : (S, s) ⇒ Ll) (hr : (S, s) ⇒ Rr) :
  Ll = Rr :=
begin
  induction' hl,
  case assign : x a s {
    cases' hr,
    refl },
  case seq_step : S S₁ T s s₁ hS₁ ih {
    cases' hr,
    case seq_step : S S₂ _ _ s₂ hS₂ {
      have hSs₁₂ := ih hS₂,
      cc },
    case seq_skip {
      cases' hS₁ } },
  case seq_skip : T s {
    cases' hr,
    case seq_step {
      cases' hr },
    case seq_skip {
      refl } },
  case ite_true : b S T s hcond {
    cases' hr,
    case ite_true {
      refl },
    case ite_false {
      cc } },
  case ite_false : b S T s hcond {
    cases' hr,
    case ite_true {
      cc },
    case ite_false {
      refl } },
  case while : b S s {
    cases' hr,
    refl }
end

/-! We can define inversion rules also about the small-step semantics. Here are
three examples: -/

lemma small_step_skip {S s t} :
  ¬ ((stmt.skip, s) ⇒ (S, t)) :=
by intro h; cases' h

@[simp] lemma small_step_seq_iff {S T s Ut} :
  (S ;; T, s) ⇒ Ut ↔
  (∃S' t, (S, s) ⇒ (S', t) ∧ Ut = (S' ;; T, t))
  ∨ (S = stmt.skip ∧ Ut = (T, s)) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    { apply or.intro_left,
      apply exists.intro S',
      apply exists.intro s',
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases' h,
    { cases' h,
      cases' h,
      cases' h,
      rw right,
      apply small_step.seq_step,
      assumption },
    { cases' h,
      rw left,
      rw right,
      apply small_step.seq_skip } }
end

@[simp] lemma small_step_ite_iff {b S T s Us} :
  (stmt.ite b S T, s) ⇒ Us ↔
  (b s ∧ Us = (S, s)) ∨ (¬ b s ∧ Us = (T, s)) :=
begin
  apply iff.intro,
  { intro h,
    cases' h,
    { apply or.intro_left,
      cc },
    { apply or.intro_right,
      cc } },
  { intro h,
    cases' h,
    { cases' h,
      rw right,
      apply small_step.ite_true,
      assumption },
    { cases' h,
      rw right,
      apply small_step.ite_false,
      assumption } }
end

/-! ### Equivalence of the Big-Step and the Small-Step Semantics (**optional**)

A more important result is the connection between the big-step and the
small-step semantics:

    `(S, s) ⟹ t ↔ (S, s) ⇒* (stmt.skip, t)`

Its proof, given below, is beyond the scope of this course. -/

lemma star_small_step_seq {S T s u}
    (h : (S, s) ⇒* (stmt.skip, u)) :
  (S ;; T, s) ⇒* (stmt.skip ;; T, u) :=
begin
  apply star.lift (λSs, (prod.fst Ss ;; T, prod.snd Ss)) _ h,
  intros Ss Ss' h,
  cases' Ss,
  cases' Ss',
  apply small_step.seq_step,
  assumption
end

lemma star_small_step_of_big_step {S s t} (h : (S, s) ⟹ t) :
  (S, s) ⇒* (stmt.skip, t) :=
begin
  induction' h,
  case skip {
    refl },
  case assign {
    exact star.single small_step.assign },
  case seq : S T s t u hS hT ihS ihT {
    transitivity,
    exact star_small_step_seq ihS,
    apply star.head small_step.seq_skip ihT },
  case ite_true : b S T s t hs hst ih {
    exact star.head (small_step.ite_true hs) ih },
  case ite_false : b S T s t hs hst ih {
    exact star.head (small_step.ite_false hs) ih },
  case while_true : b S s t u hb hS hw ihS ihw {
    exact (star.head small_step.while
      (star.head (small_step.ite_true hb)
         (star.trans (star_small_step_seq ihS)
            (star.head small_step.seq_skip ihw)))) },
  case while_false : b S s hb {
    exact star.tail (star.single small_step.while)
      (small_step.ite_false hb) }
end

lemma big_step_of_small_step_of_big_step {S₀ S₁ s₀ s₁ s₂}
  (h₁ : (S₀, s₀) ⇒ (S₁, s₁)) :
  (S₁, s₁) ⟹ s₂ → (S₀, s₀) ⟹ s₂ :=
begin
  induction' h₁;
    simp [*, big_step_while_true_iff] {contextual := tt},
  case seq_step {
    intros u hS' hT,
    apply exists.intro u,
    exact and.intro (ih hS') hT }
end

lemma big_step_of_star_small_step {S s t} :
  (S, s) ⇒* (stmt.skip, t) → (S, s) ⟹ t :=
begin
  generalize hSs : (S, s) = Ss,
  intro h,
  induction h
      using LoVe.rtc.star.head_induction_on
      with _ S's' h h' ih
      generalizing S s;
    cases' hSs,
  { exact big_step.skip },
  { cases' S's' with S' s',
    apply big_step_of_small_step_of_big_step h,
    apply ih,
    refl }
end

lemma big_step_iff_star_small_step {S s t} :
  (S, s) ⟹ t ↔ (S, s) ⇒* (stmt.skip, t) :=
iff.intro star_small_step_of_big_step
  big_step_of_star_small_step

/-! ## Parallelism (**optional**) -/

/--
a proof of `par_step i (Ss, t) (Ss', t')` represents:
"
  Let `Ss` be a list of WHILE programs that we wish to execute in parallel.
  If we evaluate one step of the `i`th program in `Ss` while in state `t`,
  we reach state `t'`, with the list of programs `Ss'` remaining to execute."
-/
inductive par_step :
    nat → list stmt × state → list stmt × state → Prop
| intro {Ss Ss' S S' s s' i}
    (hi : i < list.length Ss)
    (hS : S = list.nth_le Ss i hi)
    (hs : (S, s) ⇒ (S', s'))
    (hS' : Ss' = list.update_nth Ss i S') :
  par_step i (Ss, s) (Ss', s')

lemma par_step_diamond {i j Ss Ts Ts' s t t'}
    (hi : i < list.length Ss)
    (hj : j < list.length Ss)
    (hij : i ≠ j)
    (hT : par_step i (Ss, s) (Ts, t))
    (hT' : par_step j (Ss, s) (Ts', t')) :
  ∃u Us, par_step j (Ts, t) (Us, u) ∧
    par_step i (Ts', t') (Us, u) :=
sorry

/--
`stmt.W S` returns the set of variables written to by a thread `S`.
-/
def stmt.W : stmt → set string
| stmt.skip         := ∅
| (stmt.assign x _) := {x}
| (stmt.seq S T)    := stmt.W S ∪ stmt.W T
| (stmt.ite _ S T)  := stmt.W S ∪ stmt.W T
| (stmt.while _ S)  := stmt.W S

/--
`exp.R f` returns the set of variables read by an arithmetic or boolean expression `f`.
-/
def exp.R {α : Type} (f : state → α) : set string :=
{x | ∃ s n, f (s{x ↦ n}) ≠ f s}

/--
`stmt.R S` returns the set of variables read by a thread `S`.
-/
def stmt.R : stmt → set string
| stmt.skip         := ∅
| (stmt.assign _ a) := exp.R a
| (stmt.seq S T)    := stmt.R S ∪ stmt.R T
| (stmt.ite b S T)  := exp.R b ∪ stmt.R S ∪ stmt.R T
| (stmt.while b S)  := exp.R b ∪ stmt.R S

/--
`stmt.V S` returns the set of variables written to or read by a thread `S`.
-/
def stmt.V : stmt → set string
| S := stmt.W S ∪ stmt.R S

lemma par_step_diamond_VW_disjoint {i j Ss Ts Ts' s t t'}
    (hiS : i < list.length Ss)
    (hjT : j < list.length Ts)
    (hij : i ≠ j)
    (hT : par_step i (Ss, s) (Ts, t))
    (hT' : par_step j (Ss, s) (Ts', t'))
    (hWV : stmt.W (list.nth_le Ss i hiS)
       ∩ stmt.V (list.nth_le Ts j hjT) = ∅)
    (hVW : stmt.V (list.nth_le Ss i hiS)
       ∩ stmt.W (list.nth_le Ts j hjT) = ∅) :
  ∃u Us, par_step j (Ts, t) (Us, u) ∧
    par_step i (Ts', t') (Us, u) :=
sorry   -- this should be provable

end LoVe


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.Lean3Lib.data.vector
import Mathlib.data.list.nodup
import Mathlib.data.list.of_fn
import Mathlib.control.applicative
import Mathlib.PostPort

universes u_1 u_2 u u_3

namespace Mathlib

/-!
# Additional theorems about the `vector` type

This file introduces the infix notation `::ᵥ` for `vector.cons`.
-/

namespace vector

infixr:67 "::ᵥ" => Mathlib.vector.cons

protected instance inhabited {n : ℕ} {α : Type u_1} [Inhabited α] : Inhabited (vector α n) :=
  { default := of_fn fun (_x : fin n) => Inhabited.default }

theorem to_list_injective {n : ℕ} {α : Type u_1} : function.injective to_list :=
  subtype.val_injective

/-- Two `v w : vector α n` are equal iff they are equal at every single index. -/
theorem ext {n : ℕ} {α : Type u_1} {v : vector α n} {w : vector α n} (h : ∀ (m : fin n), nth v m = nth w m) : v = w := sorry

/-- The empty `vector` is a `subsingleton`. -/
protected instance zero_subsingleton {α : Type u_1} : subsingleton (vector α 0) :=
  subsingleton.intro fun (_x _x_1 : vector α 0) => ext fun (m : fin 0) => fin.elim0 m

@[simp] theorem cons_val {n : ℕ} {α : Type u_1} (a : α) (v : vector α n) : subtype.val (a::ᵥv) = a :: subtype.val v := sorry

@[simp] theorem cons_head {n : ℕ} {α : Type u_1} (a : α) (v : vector α n) : head (a::ᵥv) = a := sorry

@[simp] theorem cons_tail {n : ℕ} {α : Type u_1} (a : α) (v : vector α n) : tail (a::ᵥv) = v := sorry

@[simp] theorem to_list_of_fn {α : Type u_1} {n : ℕ} (f : fin n → α) : to_list (of_fn f) = list.of_fn f := sorry

@[simp] theorem mk_to_list {n : ℕ} {α : Type u_1} (v : vector α n) (h : list.length (to_list v) = n) : { val := to_list v, property := h } = v := sorry

@[simp] theorem to_list_map {n : ℕ} {α : Type u_1} {β : Type u_2} (v : vector α n) (f : α → β) : to_list (map f v) = list.map f (to_list v) :=
  subtype.cases_on v
    fun (v_val : List α) (v_property : list.length v_val = n) =>
      Eq.refl (to_list (map f { val := v_val, property := v_property }))

theorem nth_eq_nth_le {n : ℕ} {α : Type u_1} (v : vector α n) (i : fin n) : nth v i =
  list.nth_le (to_list v) (subtype.val i)
    (eq.mpr (id (Eq._oldrec (Eq.refl (subtype.val i < list.length (to_list v))) (to_list_length v)))
      (subtype.property i)) :=
  subtype.cases_on v
    fun (v_val : List α) (v_property : list.length v_val = n) =>
      idRhs (nth { val := v_val, property := v_property } i = nth { val := v_val, property := v_property } i) rfl

@[simp] theorem nth_map {n : ℕ} {α : Type u_1} {β : Type u_2} (v : vector α n) (f : α → β) (i : fin n) : nth (map f v) i = f (nth v i) := sorry

@[simp] theorem nth_of_fn {α : Type u_1} {n : ℕ} (f : fin n → α) (i : fin n) : nth (of_fn f) i = f i := sorry

@[simp] theorem of_fn_nth {n : ℕ} {α : Type u_1} (v : vector α n) : of_fn (nth v) = v := sorry

@[simp] theorem nth_tail {n : ℕ} {α : Type u_1} (v : vector α (Nat.succ n)) (i : fin n) : nth (tail v) i = nth v (fin.succ i) := sorry

@[simp] theorem tail_val {n : ℕ} {α : Type u_1} (v : vector α (Nat.succ n)) : subtype.val (tail v) = list.tail (subtype.val v) := sorry

/-- The `tail` of a `nil` vector is `nil`. -/
@[simp] theorem tail_nil {α : Type u_1} : tail nil = nil :=
  rfl

/-- The `tail` of a vector made up of one element is `nil`. -/
@[simp] theorem singleton_tail {α : Type u_1} (v : vector α 1) : tail v = nil :=
  eq.mpr (id (propext (eq_iff_true_of_subsingleton (tail v) nil))) trivial

@[simp] theorem tail_of_fn {α : Type u_1} {n : ℕ} (f : fin (Nat.succ n) → α) : tail (of_fn f) = of_fn fun (i : fin (Nat.succ n - 1)) => f (fin.succ i) := sorry

/-- The list that makes up a `vector` made up of a single element,
retrieved via `to_list`, is equal to the list of that single element. -/
@[simp] theorem to_list_singleton {α : Type u_1} (v : vector α 1) : to_list v = [head v] := sorry

/-- Mapping under `id` does not change a vector. -/
@[simp] theorem map_id {α : Type u_1} {n : ℕ} (v : vector α n) : map id v = v := sorry

theorem mem_iff_nth {n : ℕ} {α : Type u_1} {a : α} {v : vector α n} : a ∈ to_list v ↔ ∃ (i : fin n), nth v i = a := sorry

theorem nodup_iff_nth_inj {n : ℕ} {α : Type u_1} {v : vector α n} : list.nodup (to_list v) ↔ function.injective (nth v) := sorry

@[simp] theorem nth_mem {n : ℕ} {α : Type u_1} (i : fin n) (v : vector α n) : nth v i ∈ to_list v := sorry

theorem head'_to_list {n : ℕ} {α : Type u_1} (v : vector α (Nat.succ n)) : list.head' (to_list v) = some (head v) := sorry

def reverse {n : ℕ} {α : Type u_1} (v : vector α n) : vector α n :=
  { val := list.reverse (to_list v), property := sorry }

/-- The `list` of a vector after a `reverse`, retrieved by `to_list` is equal
to the `list.reverse` after retrieving a vector's `to_list`. -/
theorem to_list_reverse {n : ℕ} {α : Type u_1} {v : vector α n} : to_list (reverse v) = list.reverse (to_list v) :=
  rfl

@[simp] theorem nth_zero {n : ℕ} {α : Type u_1} (v : vector α (Nat.succ n)) : nth v 0 = head v := sorry

@[simp] theorem head_of_fn {α : Type u_1} {n : ℕ} (f : fin (Nat.succ n) → α) : head (of_fn f) = f 0 :=
  eq.mpr (id (Eq._oldrec (Eq.refl (head (of_fn f) = f 0)) (Eq.symm (nth_zero (of_fn f)))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (nth (of_fn f) 0 = f 0)) (nth_of_fn f 0))) (Eq.refl (f 0)))

@[simp] theorem nth_cons_zero {n : ℕ} {α : Type u_1} (a : α) (v : vector α n) : nth (a::ᵥv) 0 = a := sorry

/-- Accessing the `nth` element of a vector made up
of one element `x : α` is `x` itself. -/
@[simp] theorem nth_cons_nil {α : Type u_1} {ix : fin 1} (x : α) : nth (x::ᵥnil) ix = x := sorry

@[simp] theorem nth_cons_succ {n : ℕ} {α : Type u_1} (a : α) (v : vector α n) (i : fin n) : nth (a::ᵥv) (fin.succ i) = nth v i :=
  eq.mpr (id (Eq._oldrec (Eq.refl (nth (a::ᵥv) (fin.succ i) = nth v i)) (Eq.symm (nth_tail (a::ᵥv) i))))
    (eq.mpr (id (Eq._oldrec (Eq.refl (nth (tail (a::ᵥv)) i = nth v i)) (tail_cons a v))) (Eq.refl (nth v i)))

/-- The last element of a `vector`, given that the vector is at least one element. -/
def last {n : ℕ} {α : Type u_1} (v : vector α (n + 1)) : α :=
  nth v (fin.last n)

/-- The last element of a `vector`, given that the vector is at least one element. -/
theorem last_def {n : ℕ} {α : Type u_1} {v : vector α (n + 1)} : last v = nth v (fin.last n) :=
  rfl

/-- The `last` element of a vector is the `head` of the `reverse` vector. -/
theorem reverse_nth_zero {n : ℕ} {α : Type u_1} {v : vector α (n + 1)} : head (reverse v) = last v := sorry

/--
Construct a `vector β (n + 1)` from a `vector α n` by scanning `f : β → α → β`
from the "left", that is, from 0 to `fin.last n`, using `b : β` as the starting value.
-/
def scanl {n : ℕ} {α : Type u_1} {β : Type u_2} (f : β → α → β) (b : β) (v : vector α n) : vector β (n + 1) :=
  { val := list.scanl f b (to_list v), property := sorry }

/-- Providing an empty vector to `scanl` gives the starting value `b : β`. -/
@[simp] theorem scanl_nil {α : Type u_1} {β : Type u_2} (f : β → α → β) (b : β) : scanl f b nil = b::ᵥnil :=
  rfl

/--
The recursive step of `scanl` splits a vector `x ::ᵥ v : vector α (n + 1)`
into the provided starting value `b : β` and the recursed `scanl`
`f b x : β` as the starting value.

This lemma is the `cons` version of `scanl_nth`.
-/
@[simp] theorem scanl_cons {n : ℕ} {α : Type u_1} {β : Type u_2} (f : β → α → β) (b : β) (v : vector α n) (x : α) : scanl f b (x::ᵥv) = b::ᵥscanl f (f b x) v := sorry

/--
The underlying `list` of a `vector` after a `scanl` is the `list.scanl`
of the underlying `list` of the original `vector`.
-/
@[simp] theorem scanl_val {n : ℕ} {α : Type u_1} {β : Type u_2} (f : β → α → β) (b : β) {v : vector α n} : subtype.val (scanl f b v) = list.scanl f b (subtype.val v) := sorry

/--
The `to_list` of a `vector` after a `scanl` is the `list.scanl`
of the `to_list` of the original `vector`.
-/
@[simp] theorem to_list_scanl {n : ℕ} {α : Type u_1} {β : Type u_2} (f : β → α → β) (b : β) (v : vector α n) : to_list (scanl f b v) = list.scanl f b (to_list v) :=
  rfl

/--
The recursive step of `scanl` splits a vector made up of a single element
`x ::ᵥ nil : vector α 1` into a `vector` of the provided starting value `b : β`
and the mapped `f b x : β` as the last value.
-/
@[simp] theorem scanl_singleton {α : Type u_1} {β : Type u_2} (f : β → α → β) (b : β) (v : vector α 1) : scanl f b v = b::ᵥf b (head v)::ᵥnil := sorry

/--
The first element of `scanl` of a vector `v : vector α n`,
retrieved via `head`, is the starting value `b : β`.
-/
@[simp] theorem scanl_head {n : ℕ} {α : Type u_1} {β : Type u_2} (f : β → α → β) (b : β) (v : vector α n) : head (scanl f b v) = b := sorry

/--
For an index `i : fin n`, the `nth` element of `scanl` of a
vector `v : vector α n` at `i.succ`, is equal to the application
function `f : β → α → β` of the `i.cast_succ` element of
`scanl f b v` and `nth v i`.

This lemma is the `nth` version of `scanl_cons`.
-/
@[simp] theorem scanl_nth {n : ℕ} {α : Type u_1} {β : Type u_2} (f : β → α → β) (b : β) (v : vector α n) (i : fin n) : nth (scanl f b v) (fin.succ i) = f (nth (scanl f b v) (coe_fn fin.cast_succ i)) (nth v i) := sorry

def m_of_fn {m : Type u → Type u_1} [Monad m] {α : Type u} {n : ℕ} : (fin n → m α) → m (vector α n) :=
  sorry

theorem m_of_fn_pure {m : Type u_1 → Type u_2} [Monad m] [is_lawful_monad m] {α : Type u_1} {n : ℕ} (f : fin n → α) : (m_of_fn fun (i : fin n) => pure (f i)) = pure (of_fn f) := sorry

def mmap {m : Type u → Type u_1} [Monad m] {α : Type u_2} {β : Type u} (f : α → m β) {n : ℕ} : vector α n → m (vector β n) :=
  sorry

@[simp] theorem mmap_nil {m : Type u_1 → Type u_2} [Monad m] {α : Type u_3} {β : Type u_1} (f : α → m β) : mmap f nil = pure nil :=
  rfl

@[simp] theorem mmap_cons {m : Type u_1 → Type u_2} [Monad m] {α : Type u_3} {β : Type u_1} (f : α → m β) (a : α) {n : ℕ} (v : vector α n) : mmap f (a::ᵥv) =
  do
    let h' ← f a
    let t' ← mmap f v
    pure (h'::ᵥt') := sorry

/-- Define `C v` by induction on `v : vector α (n + 1)`, a vector of
at least one element.
This function has two arguments: `h0` handles the base case on `C nil`,
and `hs` defines the inductive step using `∀ x : α, C v → C (x ::ᵥ v)`. -/
def induction_on {α : Type u_1} {n : ℕ} {C : {n : ℕ} → vector α n → Sort u_2} (v : vector α (n + 1)) (h0 : C nil) (hs : {n : ℕ} → {x : α} → {w : vector α n} → C w → C (x::ᵥw)) : C v :=
  Nat.rec (fun (v : vector α (0 + 1)) => eq.mpr sorry (eq.mpr sorry (hs h0)))
    (fun (n : ℕ) (hn : (v : vector α (n + 1)) → C v) (v : vector α (Nat.succ n + 1)) => eq.mpr sorry (hs (hn (tail v)))) n
    v

def to_array {n : ℕ} {α : Type u_1} : vector α n → array n α :=
  sorry

def insert_nth {n : ℕ} {α : Type u_1} (a : α) (i : fin (n + 1)) (v : vector α n) : vector α (n + 1) :=
  { val := list.insert_nth (↑i) a (subtype.val v), property := sorry }

theorem insert_nth_val {n : ℕ} {α : Type u_1} {a : α} {i : fin (n + 1)} {v : vector α n} : subtype.val (insert_nth a i v) = list.insert_nth (subtype.val i) a (subtype.val v) :=
  rfl

@[simp] theorem remove_nth_val {n : ℕ} {α : Type u_1} {i : fin n} {v : vector α n} : subtype.val (remove_nth i v) = list.remove_nth (subtype.val v) ↑i := sorry

theorem remove_nth_insert_nth {n : ℕ} {α : Type u_1} {a : α} {v : vector α n} {i : fin (n + 1)} : remove_nth i (insert_nth a i v) = v :=
  subtype.eq (list.remove_nth_insert_nth (subtype.val i) (subtype.val v))

theorem remove_nth_insert_nth_ne {n : ℕ} {α : Type u_1} {a : α} {v : vector α (n + 1)} {i : fin (n + bit0 1)} {j : fin (n + bit0 1)} (h : i ≠ j) : remove_nth i (insert_nth a j v) = insert_nth a (fin.pred_above i j (ne.symm h)) (remove_nth (fin.pred_above j i h) v) := sorry

theorem insert_nth_comm {n : ℕ} {α : Type u_1} (a : α) (b : α) (i : fin (n + 1)) (j : fin (n + 1)) (h : i ≤ j) (v : vector α n) : insert_nth b (fin.succ j) (insert_nth a i v) = insert_nth a (coe_fn fin.cast_succ i) (insert_nth b j v) := sorry

/-- `update_nth v n a` replaces the `n`th element of `v` with `a` -/
def update_nth {n : ℕ} {α : Type u_1} (v : vector α n) (i : fin n) (a : α) : vector α n :=
  { val := list.update_nth (subtype.val v) (subtype.val i) a, property := sorry }

@[simp] theorem nth_update_nth_same {n : ℕ} {α : Type u_1} (v : vector α n) (i : fin n) (a : α) : nth (update_nth v i a) i = a := sorry

theorem nth_update_nth_of_ne {n : ℕ} {α : Type u_1} {v : vector α n} {i : fin n} {j : fin n} (h : i ≠ j) (a : α) : nth (update_nth v i a) j = nth v j := sorry

theorem nth_update_nth_eq_if {n : ℕ} {α : Type u_1} {v : vector α n} {i : fin n} {j : fin n} (a : α) : nth (update_nth v i a) j = ite (i = j) a (nth v j) := sorry

end vector

namespace vector

protected def traverse {n : ℕ} {F : Type u → Type u} [Applicative F] {α : Type u} {β : Type u} (f : α → F β) : vector α n → F (vector β n) :=
  sorry

@[simp] protected theorem traverse_def {n : ℕ} {F : Type u → Type u} [Applicative F] [is_lawful_applicative F] {α : Type u} {β : Type u} (f : α → F β) (x : α) (xs : vector α n) : vector.traverse f (x::ᵥxs) = cons <$> f x <*> vector.traverse f xs :=
  subtype.cases_on xs
    fun (xs : List α) (xs_property : list.length xs = n) =>
      eq.drec (Eq.refl (vector.traverse f (x::ᵥ{ val := xs, property := Eq.refl (list.length xs) }))) xs_property

protected theorem id_traverse {n : ℕ} {α : Type u} (x : vector α n) : vector.traverse id.mk x = x := sorry

protected theorem comp_traverse {n : ℕ} {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G] {α : Type u} {β : Type u} {γ : Type u} (f : β → F γ) (g : α → G β) (x : vector α n) : vector.traverse (functor.comp.mk ∘ Functor.map f ∘ g) x = functor.comp.mk (vector.traverse f <$> vector.traverse g x) := sorry

protected theorem traverse_eq_map_id {n : ℕ} {α : Type u_1} {β : Type u_1} (f : α → β) (x : vector α n) : vector.traverse (id.mk ∘ f) x = id.mk (map f x) := sorry

protected theorem naturality {n : ℕ} {F : Type u → Type u} {G : Type u → Type u} [Applicative F] [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G] (η : applicative_transformation F G) {α : Type u} {β : Type u} (f : α → F β) (x : vector α n) : coe_fn η (vector β n) (vector.traverse f x) = vector.traverse (coe_fn η β ∘ f) x := sorry

protected instance flip.traversable {n : ℕ} : traversable (flip vector n) :=
  traversable.mk vector.traverse

protected instance flip.is_lawful_traversable {n : ℕ} : is_lawful_traversable (flip vector n) :=
  is_lawful_traversable.mk vector.id_traverse vector.comp_traverse vector.traverse_eq_map_id vector.naturality


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mitchell Rowett, Scott Morrison, Johan Commelin, Mario Carneiro,
  Michael Howes
-/
import group_theory.subgroup.basic
import deprecated.submonoid

/-!
# Unbundled subgroups (deprecated)

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

This file is deprecated, and is no longer imported by anything in mathlib other than other
deprecated files, and test files. You should not need to import it.

This file defines unbundled multiplicative and additive subgroups. Instead of using this file,
please use `subgroup G` and `add_subgroup A`, defined in `group_theory.subgroup.basic`.

## Main definitions

`is_add_subgroup (S : set A)` : the predicate that `S` is the underlying subset of an additive
subgroup of `A`. The bundled variant `add_subgroup A` should be used in preference to this.

`is_subgroup (S : set G)` : the predicate that `S` is the underlying subset of a subgroup
of `G`. The bundled variant `subgroup G` should be used in preference to this.

## Tags

subgroup, subgroups, is_subgroup
-/
open set function

variables {G : Type*} {H : Type*} {A : Type*} {a a₁ a₂ b c: G}

section group
variables [group G] [add_group A]

/-- `s` is an additive subgroup: a set containing 0 and closed under addition and negation. -/
structure is_add_subgroup (s : set A) extends is_add_submonoid s : Prop :=
(neg_mem {a} : a ∈ s → -a ∈ s)

/-- `s` is a subgroup: a set containing 1 and closed under multiplication and inverse. -/
@[to_additive]
structure is_subgroup (s : set G) extends is_submonoid s : Prop :=
(inv_mem {a} : a ∈ s → a⁻¹ ∈ s)

@[to_additive]
lemma is_subgroup.div_mem {s : set G} (hs : is_subgroup s) {x y : G} (hx : x ∈ s) (hy : y ∈ s) :
  x / y ∈ s :=
by simpa only [div_eq_mul_inv] using hs.mul_mem hx (hs.inv_mem hy)

lemma additive.is_add_subgroup
  {s : set G} (hs : is_subgroup s) : @is_add_subgroup (additive G) _ s :=
@is_add_subgroup.mk (additive G) _ _ (additive.is_add_submonoid hs.to_is_submonoid) $
  λ _, hs.inv_mem

theorem additive.is_add_subgroup_iff
  {s : set G} : @is_add_subgroup (additive G) _ s ↔ is_subgroup s :=
⟨by rintro ⟨⟨h₁, h₂⟩, h₃⟩; exact @is_subgroup.mk G _ _ ⟨h₁, @h₂⟩ @h₃,
  λ h, by exactI additive.is_add_subgroup h⟩

lemma multiplicative.is_subgroup
  {s : set A} (hs : is_add_subgroup s) : @is_subgroup (multiplicative A) _ s :=
@is_subgroup.mk (multiplicative A) _ _ (multiplicative.is_submonoid hs.to_is_add_submonoid) $
  λ _, hs.neg_mem

theorem multiplicative.is_subgroup_iff
  {s : set A} : @is_subgroup (multiplicative A) _ s ↔ is_add_subgroup s :=
⟨by rintro ⟨⟨h₁, h₂⟩, h₃⟩; exact @is_add_subgroup.mk A _ _ ⟨h₁, @h₂⟩ @h₃,
  λ h, by exactI multiplicative.is_subgroup h⟩

@[to_additive of_add_neg]
theorem is_subgroup.of_div (s : set G)
  (one_mem : (1:G) ∈ s) (div_mem : ∀{a b:G}, a ∈ s → b ∈ s → a * b⁻¹ ∈ s) :
  is_subgroup s :=
have inv_mem : ∀a, a ∈ s → a⁻¹ ∈ s, from
  assume a ha,
  have 1 * a⁻¹ ∈ s, from div_mem one_mem ha,
  by simpa,
{ inv_mem := inv_mem,
  mul_mem := assume a b ha hb,
    have a * b⁻¹⁻¹ ∈ s, from div_mem ha (inv_mem b hb),
    by simpa,
  one_mem := one_mem }

theorem is_add_subgroup.of_sub (s : set A)
  (zero_mem : (0:A) ∈ s) (sub_mem : ∀{a b:A}, a ∈ s → b ∈ s → a - b ∈ s) :
  is_add_subgroup s :=
is_add_subgroup.of_add_neg s zero_mem
  (λ x y hx hy, by simpa only [sub_eq_add_neg] using sub_mem hx hy)

@[to_additive]
lemma is_subgroup.inter {s₁ s₂ : set G} (hs₁ : is_subgroup s₁) (hs₂ : is_subgroup s₂) :
  is_subgroup (s₁ ∩ s₂) :=
{ inv_mem := λ x hx, ⟨hs₁.inv_mem hx.1, hs₂.inv_mem hx.2⟩,
  ..is_submonoid.inter hs₁.to_is_submonoid hs₂.to_is_submonoid}

@[to_additive]
lemma is_subgroup.Inter {ι : Sort*} {s : ι → set G} (hs : ∀ y : ι, is_subgroup (s y)) :
  is_subgroup (set.Inter s) :=
{ inv_mem := λ x h, set.mem_Inter.2 $ λ y, is_subgroup.inv_mem (hs _) (set.mem_Inter.1 h y),
  ..is_submonoid.Inter (λ y, (hs y).to_is_submonoid) }

@[to_additive]
lemma is_subgroup_Union_of_directed {ι : Type*} [hι : nonempty ι]
  {s : ι → set G} (hs : ∀ i, is_subgroup (s i))
  (directed : ∀ i j, ∃ k, s i ⊆ s k ∧ s j ⊆ s k) :
  is_subgroup (⋃i, s i) :=
{ inv_mem := λ a ha,
    let ⟨i, hi⟩ := set.mem_Union.1 ha in
    set.mem_Union.2 ⟨i, (hs i).inv_mem hi⟩,
  to_is_submonoid := is_submonoid_Union_of_directed (λ i, (hs i).to_is_submonoid) directed }

end group

namespace is_subgroup
open is_submonoid
variables [group G] {s : set G} (hs : is_subgroup s)

include hs

@[to_additive]
lemma inv_mem_iff : a⁻¹ ∈ s ↔ a ∈ s :=
⟨λ h, by simpa using hs.inv_mem h, inv_mem hs⟩

@[to_additive]
lemma mul_mem_cancel_right (h : a ∈ s) : b * a ∈ s ↔ b ∈ s :=
⟨λ hba, by simpa using hs.mul_mem hba (hs.inv_mem h), λ hb, hs.mul_mem hb h⟩

@[to_additive]
lemma mul_mem_cancel_left (h : a ∈ s) : a * b ∈ s ↔ b ∈ s :=
⟨λ hab, by simpa using hs.mul_mem (hs.inv_mem h) hab, hs.mul_mem h⟩

end is_subgroup

/-- `is_normal_add_subgroup (s : set A)` expresses the fact that `s` is a normal additive subgroup
of the additive group `A`. Important: the preferred way to say this in Lean is via bundled
subgroups `S : add_subgroup A` and `hs : S.normal`, and not via this structure. -/
structure is_normal_add_subgroup [add_group A] (s : set A) extends is_add_subgroup s : Prop :=
(normal : ∀ n ∈ s, ∀ g : A, g + n + -g ∈ s)

/-- `is_normal_subgroup (s : set G)` expresses the fact that `s` is a normal subgroup
of the group `G`. Important: the preferred way to say this in Lean is via bundled
subgroups `S : subgroup G` and not via this structure. -/
@[to_additive]
structure is_normal_subgroup [group G] (s : set G) extends is_subgroup s : Prop :=
(normal : ∀ n ∈ s, ∀ g : G, g * n * g⁻¹ ∈ s)

@[to_additive]
lemma is_normal_subgroup_of_comm_group [comm_group G] {s : set G} (hs : is_subgroup s) :
  is_normal_subgroup s :=
{ normal := λ n hn g, by rwa [mul_right_comm, mul_right_inv, one_mul],
  ..hs }

lemma additive.is_normal_add_subgroup [group G]
  {s : set G} (hs : is_normal_subgroup s) : @is_normal_add_subgroup (additive G) _ s :=
@is_normal_add_subgroup.mk (additive G) _ _
  (additive.is_add_subgroup hs.to_is_subgroup)
  (is_normal_subgroup.normal hs)

theorem additive.is_normal_add_subgroup_iff [group G]
  {s : set G} : @is_normal_add_subgroup (additive G) _ s ↔ is_normal_subgroup s :=
⟨by rintro ⟨h₁, h₂⟩; exact
    @is_normal_subgroup.mk G _ _ (additive.is_add_subgroup_iff.1 h₁) @h₂,
  λ h, by exactI additive.is_normal_add_subgroup h⟩

lemma multiplicative.is_normal_subgroup [add_group A]
  {s : set A} (hs : is_normal_add_subgroup s) : @is_normal_subgroup (multiplicative A) _ s :=
@is_normal_subgroup.mk (multiplicative A) _ _
  (multiplicative.is_subgroup hs.to_is_add_subgroup)
  (is_normal_add_subgroup.normal hs)

theorem multiplicative.is_normal_subgroup_iff [add_group A]
  {s : set A} : @is_normal_subgroup (multiplicative A) _ s ↔ is_normal_add_subgroup s :=
⟨by rintro ⟨h₁, h₂⟩; exact
    @is_normal_add_subgroup.mk A _ _ (multiplicative.is_subgroup_iff.1 h₁) @h₂,
  λ h, by exactI multiplicative.is_normal_subgroup h⟩

namespace is_subgroup
variable [group G]

-- Normal subgroup properties
@[to_additive]
lemma mem_norm_comm {s : set G} (hs : is_normal_subgroup s) {a b : G} (hab : a * b ∈ s) :
  b * a ∈ s :=
have h : a⁻¹ * (a * b) * a⁻¹⁻¹ ∈ s, from hs.normal (a * b) hab a⁻¹,
by simp at h; exact h

@[to_additive]
lemma mem_norm_comm_iff {s : set G} (hs : is_normal_subgroup s) {a b : G} : a * b ∈ s ↔ b * a ∈ s :=
⟨mem_norm_comm hs, mem_norm_comm hs⟩

/-- The trivial subgroup -/
@[to_additive "the trivial additive subgroup"]
def trivial (G : Type*) [group G] : set G := {1}

@[simp, to_additive]
lemma mem_trivial {g : G} : g ∈ trivial G ↔ g = 1 :=
mem_singleton_iff

@[to_additive]
lemma trivial_normal : is_normal_subgroup (trivial G) :=
by refine {..}; simp [trivial] {contextual := tt}

@[to_additive]
lemma eq_trivial_iff {s : set G} (hs : is_subgroup s) :
  s = trivial G ↔ (∀ x ∈ s, x = (1 : G)) :=
by simp only [set.ext_iff, is_subgroup.mem_trivial];
  exact ⟨λ h x, (h x).1, λ h x, ⟨h x, λ hx, hx.symm ▸ hs.to_is_submonoid.one_mem⟩⟩

@[to_additive]
lemma univ_subgroup : is_normal_subgroup (@univ G) :=
by refine {..}; simp

/-- The underlying set of the center of a group. -/
@[to_additive add_center "The underlying set of the center of an additive group."]
def center (G : Type*) [group G] : set G := {z | ∀ g, g * z = z * g}

@[to_additive mem_add_center]
lemma mem_center {a : G} : a ∈ center G ↔ ∀g, g * a = a * g := iff.rfl

@[to_additive add_center_normal]
lemma center_normal : is_normal_subgroup (center G) :=
{ one_mem := by simp [center],
  mul_mem := assume a b ha hb g,
    by rw [←mul_assoc, mem_center.2 ha g, mul_assoc, mem_center.2 hb g, ←mul_assoc],
  inv_mem := assume a ha g,
    calc
      g * a⁻¹ = a⁻¹ * (g * a) * a⁻¹ : by simp [ha g]
      ...     = a⁻¹ * g             : by rw [←mul_assoc, mul_assoc]; simp,
  normal := assume n ha g h,
    calc
      h * (g * n * g⁻¹) = h * n           : by simp [ha g, mul_assoc]
      ...               = g * g⁻¹ * n * h : by rw ha h; simp
      ...               = g * n * g⁻¹ * h : by rw [mul_assoc g, ha g⁻¹, ←mul_assoc] }

/-- The underlying set of the normalizer of a subset `S : set G` of a group `G`. That is,
  the elements `g : G` such that `g * S * g⁻¹ = S`. -/
@[to_additive add_normalizer "The underlying set of the normalizer of a subset `S : set A` of an
  additive group `A`. That is, the elements `a : A` such that `a + S - a = S`."]
def normalizer (s : set G) : set G :=
{g : G | ∀ n, n ∈ s ↔ g * n * g⁻¹ ∈ s}

@[to_additive]
lemma normalizer_is_subgroup (s : set G) : is_subgroup (normalizer s) :=
{ one_mem := by simp [normalizer],
  mul_mem := λ a b (ha : ∀ n, n ∈ s ↔ a * n * a⁻¹ ∈ s)
    (hb : ∀ n, n ∈ s ↔ b * n * b⁻¹ ∈ s) n,
    by rw [mul_inv_rev, ← mul_assoc, mul_assoc a, mul_assoc a, ← ha, ← hb],
  inv_mem := λ a (ha : ∀ n, n ∈ s ↔ a * n * a⁻¹ ∈ s) n,
    by rw [ha (a⁻¹ * n * a⁻¹⁻¹)];
    simp [mul_assoc] }

@[to_additive subset_add_normalizer]
lemma subset_normalizer {s : set G} (hs : is_subgroup s) : s ⊆ normalizer s :=
λ g hg n, by rw [is_subgroup.mul_mem_cancel_right hs ((is_subgroup.inv_mem_iff hs).2 hg),
  is_subgroup.mul_mem_cancel_left hs hg]

end is_subgroup

-- Homomorphism subgroups
namespace is_group_hom
open is_submonoid is_subgroup

/-- `ker f : set G` is the underlying subset of the kernel of a map `G → H`. -/
@[to_additive "`ker f : set A` is the underlying subset of the kernel of a map `A → B`"]
def ker [group H] (f : G → H) : set G := preimage f (trivial H)

@[to_additive]
lemma mem_ker [group H] (f : G → H) {x : G} : x ∈ ker f ↔ f x = 1 :=
mem_trivial

variables [group G] [group H]

@[to_additive]
lemma one_ker_inv {f : G → H} (hf : is_group_hom f) {a b : G} (h : f (a * b⁻¹) = 1) : f a = f b :=
begin
  rw [hf.map_mul, hf.map_inv] at h,
  rw [←inv_inv (f b), eq_inv_of_mul_eq_one_left h]
end

@[to_additive]
lemma one_ker_inv' {f : G → H} (hf : is_group_hom f) {a b : G} (h : f (a⁻¹ * b) = 1) : f a = f b :=
begin
  rw [hf.map_mul, hf.map_inv] at h,
  apply inv_injective,
  rw eq_inv_of_mul_eq_one_left h
end

@[to_additive]
lemma inv_ker_one {f : G → H} (hf : is_group_hom f) {a b : G} (h : f a = f b) : f (a * b⁻¹) = 1 :=
have f a * (f b)⁻¹ = 1, by rw [h, mul_right_inv],
by rwa [←hf.map_inv, ←hf.map_mul] at this

@[to_additive]
lemma inv_ker_one' {f : G → H} (hf : is_group_hom f) {a b : G} (h : f a = f b) : f (a⁻¹ * b) = 1 :=
have (f a)⁻¹ * f b = 1, by rw [h, mul_left_inv],
by rwa [←hf.map_inv, ←hf.map_mul] at this

@[to_additive]
lemma one_iff_ker_inv {f : G → H} (hf : is_group_hom f) (a b : G) : f a = f b ↔ f (a * b⁻¹) = 1 :=
⟨hf.inv_ker_one, hf.one_ker_inv⟩

@[to_additive]
lemma one_iff_ker_inv' {f : G → H} (hf : is_group_hom f) (a b : G) : f a = f b ↔ f (a⁻¹ * b) = 1 :=
⟨hf.inv_ker_one', hf.one_ker_inv'⟩

@[to_additive]
lemma inv_iff_ker {f : G → H} (hf : is_group_hom f) (a b : G) : f a = f b ↔ a * b⁻¹ ∈ ker f :=
by rw [mem_ker]; exact one_iff_ker_inv hf _ _

@[to_additive]
lemma inv_iff_ker' {f : G → H} (hf : is_group_hom f) (a b : G) : f a = f b ↔ a⁻¹ * b ∈ ker f :=
by rw [mem_ker]; exact one_iff_ker_inv' hf _ _

@[to_additive]
lemma image_subgroup {f : G → H} (hf : is_group_hom f) {s : set G} (hs : is_subgroup s) :
  is_subgroup (f '' s) :=
{ mul_mem := assume a₁ a₂ ⟨b₁, hb₁, eq₁⟩ ⟨b₂, hb₂, eq₂⟩,
             ⟨b₁ * b₂, hs.mul_mem hb₁ hb₂, by simp [eq₁, eq₂, hf.map_mul]⟩,
  one_mem := ⟨1, hs.to_is_submonoid.one_mem, hf.map_one⟩,
  inv_mem := assume a ⟨b, hb, eq⟩, ⟨b⁻¹, hs.inv_mem hb, by { rw hf.map_inv, simp * }⟩ }

@[to_additive]
lemma range_subgroup {f : G → H} (hf : is_group_hom f) : is_subgroup (set.range f) :=
@set.image_univ _ _ f ▸ hf.image_subgroup univ_subgroup.to_is_subgroup

local attribute [simp] one_mem inv_mem mul_mem is_normal_subgroup.normal

@[to_additive]
lemma preimage {f : G → H} (hf : is_group_hom f) {s : set H} (hs : is_subgroup s) :
  is_subgroup (f ⁻¹' s) :=
by { refine {..};
     simp [hs.one_mem, hs.mul_mem, hs.inv_mem, hf.map_mul, hf.map_one, hf.map_inv,
           inv_mem_class.inv_mem]
     {contextual := tt} }

@[to_additive]
lemma preimage_normal {f : G → H} (hf : is_group_hom f) {s : set H} (hs : is_normal_subgroup s) :
  is_normal_subgroup (f ⁻¹' s) :=
{ one_mem := by simp [hf.map_one, hs.to_is_subgroup.one_mem],
  mul_mem := by simp [hf.map_mul, hs.to_is_subgroup.mul_mem] {contextual := tt},
  inv_mem := by simp [hf.map_inv, hs.to_is_subgroup.inv_mem] {contextual := tt},
  normal := by simp [hs.normal, hf.map_mul, hf.map_inv] {contextual := tt}}

@[to_additive]
lemma is_normal_subgroup_ker {f : G → H} (hf : is_group_hom f) : is_normal_subgroup (ker f) :=
hf.preimage_normal (trivial_normal)

@[to_additive]
lemma injective_of_trivial_ker {f : G → H} (hf : is_group_hom f) (h : ker f = trivial G) :
  function.injective f :=
begin
  intros a₁ a₂ hfa,
  simp [ext_iff, ker, is_subgroup.trivial] at h,
  have ha : a₁ * a₂⁻¹ = 1, by rw ←h; exact hf.inv_ker_one hfa,
  rw [eq_inv_of_mul_eq_one_left ha, inv_inv a₂]
end

@[to_additive]
lemma trivial_ker_of_injective {f : G → H} (hf : is_group_hom f) (h : function.injective f) :
  ker f = trivial G :=
set.ext $ assume x, iff.intro
  (assume hx,
    suffices f x = f 1, by simpa using h this,
    by simp [hf.map_one]; rwa [mem_ker] at hx)
  (by simp [mem_ker, hf.map_one] {contextual := tt})

@[to_additive]
lemma injective_iff_trivial_ker {f : G → H} (hf : is_group_hom f) :
  function.injective f ↔ ker f = trivial G :=
⟨hf.trivial_ker_of_injective, hf.injective_of_trivial_ker⟩

@[to_additive]
lemma trivial_ker_iff_eq_one {f : G → H} (hf : is_group_hom f) :
  ker f = trivial G ↔ ∀ x, f x = 1 → x = 1 :=
by rw set.ext_iff; simp [ker]; exact
⟨λ h x hx, (h x).1 hx, λ h x, ⟨h x, λ hx, by rw [hx, hf.map_one]⟩⟩

end is_group_hom

namespace add_group

variables [add_group A]

/-- If `A` is an additive group and `s : set A`, then `in_closure s : set A` is the underlying
subset of the subgroup generated by `s`. -/
inductive in_closure (s : set A) : A → Prop
| basic {a : A} : a ∈ s → in_closure a
| zero : in_closure 0
| neg {a : A} : in_closure a → in_closure (-a)
| add {a b : A} : in_closure a → in_closure b → in_closure (a + b)

end add_group

namespace group
open is_submonoid is_subgroup

variables [group G] {s : set G}

/-- If `G` is a group and `s : set G`, then `in_closure s : set G` is the underlying
subset of the subgroup generated by `s`. -/
@[to_additive]
inductive in_closure (s : set G) : G → Prop
| basic {a : G} : a ∈ s → in_closure a
| one : in_closure 1
| inv {a : G} : in_closure a → in_closure a⁻¹
| mul {a b : G} : in_closure a → in_closure b → in_closure (a * b)

/-- `group.closure s` is the subgroup generated by `s`, i.e. the smallest subgroup containg `s`. -/
@[to_additive "`add_group.closure s` is the additive subgroup generated by `s`, i.e., the
  smallest additive subgroup containing `s`."]
def closure (s : set G) : set G := {a | in_closure s a }

@[to_additive]
lemma mem_closure {a : G} : a ∈ s → a ∈ closure s := in_closure.basic

@[to_additive]
lemma closure.is_subgroup (s : set G) : is_subgroup (closure s) :=
{ one_mem := in_closure.one,
  mul_mem := assume a b, in_closure.mul,
  inv_mem := assume a, in_closure.inv }

@[to_additive]
theorem subset_closure {s : set G} : s ⊆ closure s := λ a, mem_closure

@[to_additive]
theorem closure_subset {s t : set G} (ht : is_subgroup t) (h : s ⊆ t) : closure s ⊆ t :=
assume a ha, by induction ha; simp [h _, *, ht.one_mem, ht.mul_mem, is_subgroup.inv_mem_iff]

@[to_additive]
lemma closure_subset_iff {s t : set G} (ht : is_subgroup t) : closure s ⊆ t ↔ s ⊆ t :=
⟨assume h b ha, h (mem_closure ha), assume h b ha, closure_subset ht h ha⟩

@[to_additive]
theorem closure_mono {s t : set G} (h : s ⊆ t) : closure s ⊆ closure t :=
closure_subset (closure.is_subgroup _) $ set.subset.trans h subset_closure

@[simp, to_additive]
lemma closure_subgroup {s : set G} (hs : is_subgroup s) : closure s = s :=
set.subset.antisymm (closure_subset hs $ set.subset.refl s) subset_closure

@[to_additive]

@[to_additive]
lemma image_closure [group H] {f : G → H} (hf : is_group_hom f) (s : set G) :
  f '' closure s = closure (f '' s) :=
le_antisymm
  begin
    rintros _ ⟨x, hx, rfl⟩,
    apply in_closure.rec_on hx; intros,
    { solve_by_elim [subset_closure, set.mem_image_of_mem] },
    { rw [hf.to_is_monoid_hom.map_one],
      apply is_submonoid.one_mem (closure.is_subgroup _).to_is_submonoid, },
    { rw [hf.map_inv],
      apply is_subgroup.inv_mem (closure.is_subgroup _), assumption },
    { rw [hf.to_is_monoid_hom.map_mul],
      solve_by_elim [is_submonoid.mul_mem (closure.is_subgroup _).to_is_submonoid] }
  end
  (closure_subset (hf.image_subgroup $ closure.is_subgroup _) $ set.image_subset _ subset_closure)

@[to_additive]
theorem mclosure_subset {s : set G} : monoid.closure s ⊆ closure s :=
monoid.closure_subset (closure.is_subgroup _).to_is_submonoid $ subset_closure

@[to_additive]
theorem mclosure_inv_subset {s : set G} : monoid.closure (has_inv.inv ⁻¹' s) ⊆ closure s :=
monoid.closure_subset (closure.is_subgroup _).to_is_submonoid $ λ x hx,
  inv_inv x ▸ ((closure.is_subgroup _).inv_mem $ subset_closure hx)

@[to_additive]
theorem closure_eq_mclosure {s : set G} : closure s = monoid.closure (s ∪ has_inv.inv ⁻¹' s) :=
set.subset.antisymm
  (@closure_subset _ _ _ (monoid.closure (s ∪ has_inv.inv ⁻¹' s))
    { one_mem := (monoid.closure.is_submonoid _).one_mem,
      mul_mem := λ _ _, (monoid.closure.is_submonoid _).mul_mem,
      inv_mem := λ x hx, monoid.in_closure.rec_on hx
      (λ x hx, or.cases_on hx (λ hx, monoid.subset_closure $ or.inr $
        show x⁻¹⁻¹ ∈ s, from (inv_inv x).symm ▸ hx)
        (λ hx, monoid.subset_closure $ or.inl hx))
      ((@inv_one G _).symm ▸ is_submonoid.one_mem (monoid.closure.is_submonoid _))
      (λ x y hx hy ihx ihy,
        (mul_inv_rev x y).symm ▸ is_submonoid.mul_mem (monoid.closure.is_submonoid _) ihy ihx) }
    (set.subset.trans (set.subset_union_left _ _) monoid.subset_closure))
  (monoid.closure_subset (closure.is_subgroup _).to_is_submonoid $ set.union_subset subset_closure $
    λ x hx, inv_inv x ▸ (is_subgroup.inv_mem (closure.is_subgroup _) $ subset_closure hx))

@[to_additive]
theorem mem_closure_union_iff {G : Type*} [comm_group G] {s t : set G} {x : G} :
  x ∈ closure (s ∪ t) ↔ ∃ y ∈ closure s, ∃ z ∈ closure t, y * z = x :=
begin
  simp only [closure_eq_mclosure, monoid.mem_closure_union_iff, exists_prop, preimage_union], split,
  { rintro ⟨_, ⟨ys, hys, yt, hyt, rfl⟩, _, ⟨zs, hzs, zt, hzt, rfl⟩, rfl⟩,
    refine ⟨_, ⟨_, hys, _, hzs, rfl⟩, _, ⟨_, hyt, _, hzt, rfl⟩, _⟩,
    rw [mul_assoc, mul_assoc, mul_left_comm zs] },
  { rintro ⟨_, ⟨ys, hys, zs, hzs, rfl⟩, _, ⟨yt, hyt, zt, hzt, rfl⟩, rfl⟩,
    refine ⟨_, ⟨ys, hys, yt, hyt, rfl⟩, _, ⟨zs, hzs, zt, hzt, rfl⟩, _⟩,
    rw [mul_assoc, mul_assoc, mul_left_comm yt] }
end

end group

namespace is_subgroup
variable [group G]

@[to_additive]
lemma trivial_eq_closure : trivial G = group.closure ∅ :=
subset.antisymm
  (by simp [set.subset_def, (group.closure.is_subgroup _).one_mem])
  (group.closure_subset (trivial_normal).to_is_subgroup $ by simp)

end is_subgroup

/-The normal closure of a set s is the subgroup closure of all the conjugates of
elements of s. It is the smallest normal subgroup containing s. -/

namespace group
variables {s : set G} [group G]

lemma conjugates_of_subset {t : set G} (ht : is_normal_subgroup t) {a : G} (h : a ∈ t) :
  conjugates_of a ⊆ t :=
λ x hc,
begin
  obtain ⟨c, w⟩ := is_conj_iff.1 hc,
  have H := is_normal_subgroup.normal ht a h c,
  rwa ←w,
end

theorem conjugates_of_set_subset' {s t : set G} (ht : is_normal_subgroup t) (h : s ⊆ t) :
  conjugates_of_set s ⊆ t :=
set.Union₂_subset (λ x H, conjugates_of_subset ht (h H))

/-- The normal closure of a set s is the subgroup closure of all the conjugates of
elements of s. It is the smallest normal subgroup containing s. -/
def normal_closure (s : set G) : set G := closure (conjugates_of_set s)

theorem conjugates_of_set_subset_normal_closure : conjugates_of_set s ⊆ normal_closure s :=
subset_closure

theorem subset_normal_closure : s ⊆ normal_closure s :=
set.subset.trans subset_conjugates_of_set conjugates_of_set_subset_normal_closure

/-- The normal closure of a set is a subgroup. -/
lemma normal_closure.is_subgroup (s : set G) : is_subgroup (normal_closure s) :=
closure.is_subgroup (conjugates_of_set s)

/-- The normal closure of s is a normal subgroup. -/
lemma normal_closure.is_normal : is_normal_subgroup (normal_closure s) :=
{ normal := λ n h g,
begin
  induction h with x hx x hx ihx x y hx hy ihx ihy,
  {exact (conjugates_of_set_subset_normal_closure (conj_mem_conjugates_of_set hx))},
  {simpa using (normal_closure.is_subgroup s).one_mem},
  {rw ←conj_inv,
   exact ((normal_closure.is_subgroup _).inv_mem ihx)},
  {rw ←conj_mul,
   exact ((normal_closure.is_subgroup _).to_is_submonoid.mul_mem ihx ihy)},
end,
..normal_closure.is_subgroup _ }

/-- The normal closure of s is the smallest normal subgroup containing s. -/
theorem normal_closure_subset {s t : set G} (ht : is_normal_subgroup t) (h : s ⊆ t) :
  normal_closure s ⊆ t :=
λ a w,
begin
  induction w with x hx x hx ihx x y hx hy ihx ihy,
  {exact (conjugates_of_set_subset' ht h $ hx)},
  {exact ht.to_is_subgroup.to_is_submonoid.one_mem},
  {exact ht.to_is_subgroup.inv_mem ihx},
  {exact ht.to_is_subgroup.to_is_submonoid.mul_mem ihx ihy}
end

lemma normal_closure_subset_iff {s t : set G} (ht : is_normal_subgroup t) :
  s ⊆ t ↔ normal_closure s ⊆ t :=
⟨normal_closure_subset ht, set.subset.trans (subset_normal_closure)⟩

theorem normal_closure_mono {s t : set G} : s ⊆ t → normal_closure s ⊆ normal_closure t :=
λ h, normal_closure_subset normal_closure.is_normal (set.subset.trans h (subset_normal_closure))

end group

/-- Create a bundled subgroup from a set `s` and `[is_subgroup s]`. -/
@[to_additive "Create a bundled additive subgroup from a set `s` and `[is_add_subgroup s]`."]
def subgroup.of [group G] {s : set G} (h : is_subgroup s) : subgroup G :=
{ carrier := s,
  one_mem' := h.1.1,
  mul_mem' := λ _ _, h.1.2,
  inv_mem' := λ _, h.2 }

@[to_additive]
lemma subgroup.is_subgroup [group G] (K : subgroup G) : is_subgroup (K : set G) :=
{ one_mem := K.one_mem',
  mul_mem := λ _ _, K.mul_mem',
  inv_mem := λ _, K.inv_mem' }

-- this will never fire if it's an instance
@[to_additive]
lemma subgroup.of_normal [group G] (s : set G) (h : is_subgroup s) (n : is_normal_subgroup s) :
  subgroup.normal (subgroup.of h) :=
{ conj_mem := n.normal, }


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.adjunction.basic
import category_theory.conj
import category_theory.yoneda

/-!
# Adjoints of fully faithful functors

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

A left adjoint is fully faithful, if and only if the unit is an isomorphism
(and similarly for right adjoints and the counit).

`adjunction.restrict_fully_faithful` shows that an adjunction can be restricted along fully faithful
inclusions.

## Future work

The statements from Riehl 4.5.13 for adjoints which are either full, or faithful.
-/

open category_theory

namespace category_theory
universes v₁ v₂ u₁ u₂

open category
open opposite

variables {C : Type u₁} [category.{v₁} C]
variables {D : Type u₂} [category.{v₂} D]
variables {L : C ⥤ D} {R : D ⥤ C} (h : L ⊣ R)

/--
If the left adjoint is fully faithful, then the unit is an isomorphism.

See
* Lemma 4.5.13 from [Riehl][riehl2017]
* https://math.stackexchange.com/a/2727177
* https://stacks.math.columbia.edu/tag/07RB (we only prove the forward direction!)
-/
instance unit_is_iso_of_L_fully_faithful [full L] [faithful L] : is_iso (adjunction.unit h) :=
@nat_iso.is_iso_of_is_iso_app _ _ _ _ _ _ (adjunction.unit h) $ λ X,
@yoneda.is_iso _ _ _ _ ((adjunction.unit h).app X)
⟨⟨{ app := λ Y f, L.preimage ((h.hom_equiv (unop Y) (L.obj X)).symm f) },
  ⟨begin
    ext x f, dsimp,
    apply L.map_injective,
    simp,
  end, begin
    ext x f, dsimp,
    simp only [adjunction.hom_equiv_counit, preimage_comp, preimage_map, category.assoc],
    rw ←h.unit_naturality,
    simp,
  end⟩⟩⟩

/--
If the right adjoint is fully faithful, then the counit is an isomorphism.

See <https://stacks.math.columbia.edu/tag/07RB> (we only prove the forward direction!)
-/
instance counit_is_iso_of_R_fully_faithful [full R] [faithful R] : is_iso (adjunction.counit h) :=
@nat_iso.is_iso_of_is_iso_app _ _ _ _ _ _ (adjunction.counit h) $ λ X,
@is_iso_of_op _ _ _ _ _ $
@coyoneda.is_iso _ _ _ _ ((adjunction.counit h).app X).op
⟨⟨{ app := λ Y f, R.preimage ((h.hom_equiv (R.obj X) Y) f) },
  ⟨begin
    ext x f, dsimp,
    apply R.map_injective,
    simp,
  end, begin
    ext x f, dsimp,
    simp only [adjunction.hom_equiv_unit, preimage_comp, preimage_map],
    rw ←h.counit_naturality,
    simp,
  end⟩⟩⟩

/-- If the unit of an adjunction is an isomorphism, then its inverse on the image of L is given
by L whiskered with the counit. -/
@[simp]
lemma inv_map_unit {X : C} [is_iso (h.unit.app X)] :
  inv (L.map (h.unit.app X)) = h.counit.app (L.obj X) :=
is_iso.inv_eq_of_hom_inv_id h.left_triangle_components

/-- If the unit is an isomorphism, bundle one has an isomorphism `L ⋙ R ⋙ L ≅ L`. -/
@[simps]
noncomputable def whisker_left_L_counit_iso_of_is_iso_unit [is_iso h.unit] :
  L ⋙ R ⋙ L ≅ L :=
(L.associator R L).symm ≪≫ iso_whisker_right (as_iso h.unit).symm L ≪≫ functor.left_unitor _

/-- If the counit of an adjunction is an isomorphism, then its inverse on the image of R is given
by R whiskered with the unit. -/
@[simp]
lemma inv_counit_map {X : D} [is_iso (h.counit.app X)] :
  inv (R.map (h.counit.app X)) = h.unit.app (R.obj X) :=
is_iso.inv_eq_of_inv_hom_id h.right_triangle_components

/-- If the counit of an is an isomorphism, one has an isomorphism `(R ⋙ L ⋙ R) ≅ R`. -/
@[simps]
noncomputable def whisker_left_R_unit_iso_of_is_iso_counit [is_iso h.counit] :
  (R ⋙ L ⋙ R) ≅ R :=
(R.associator L R).symm ≪≫ iso_whisker_right (as_iso h.counit) R ≪≫ functor.left_unitor _

/-- If the unit is an isomorphism, then the left adjoint is full-/
noncomputable
def L_full_of_unit_is_iso [is_iso h.unit] : full L :=
{ preimage := λ X Y f, (h.hom_equiv X (L.obj Y) f) ≫ inv (h.unit.app Y) }

/-- If the unit is an isomorphism, then the left adjoint is faithful-/
lemma L_faithful_of_unit_is_iso [is_iso h.unit] : faithful L :=
{ map_injective' := λ X Y f g H,
  begin
    rw ←(h.hom_equiv X (L.obj Y)).apply_eq_iff_eq at H,
    simpa using H =≫ inv (h.unit.app Y),
  end }

/-- If the counit is an isomorphism, then the right adjoint is full-/
noncomputable
def R_full_of_counit_is_iso [is_iso h.counit] : full R :=
{ preimage := λ X Y f, inv (h.counit.app X) ≫ (h.hom_equiv (R.obj X) Y).symm f }

/-- If the counit is an isomorphism, then the right adjoint is faithful-/
lemma R_faithful_of_counit_is_iso [is_iso h.counit] : faithful R :=
{ map_injective' := λ X Y f g H,
  begin
    rw ←(h.hom_equiv (R.obj X) Y).symm.apply_eq_iff_eq at H,
    simpa using inv (h.counit.app X) ≫= H,
  end }

instance whisker_left_counit_iso_of_L_fully_faithful
  [full L] [faithful L] : is_iso (whisker_left L h.counit) :=
begin
  have := h.left_triangle,
  rw ←is_iso.eq_inv_comp at this,
  rw this,
  apply_instance
end

instance whisker_right_counit_iso_of_L_fully_faithful
  [full L] [faithful L] : is_iso (whisker_right h.counit R) :=
begin
  have := h.right_triangle,
  rw ←is_iso.eq_inv_comp at this,
  rw this,
  apply_instance
end

instance whisker_left_unit_iso_of_R_fully_faithful
  [full R] [faithful R] : is_iso (whisker_left R h.unit) :=
begin
  have := h.right_triangle,
  rw ←is_iso.eq_comp_inv at this,
  rw this,
  apply_instance
end

instance whisker_right_unit_iso_of_R_fully_faithful
  [full R] [faithful R] : is_iso (whisker_right h.unit L) :=
begin
  have := h.left_triangle,
  rw ←is_iso.eq_comp_inv at this,
  rw this,
  apply_instance
end

-- TODO also do the statements from Riehl 4.5.13 for full and faithful separately?

universes v₃ v₄ u₃ u₄

variables {C' : Type u₃} [category.{v₃} C']
variables {D' : Type u₄} [category.{v₄} D']

-- TODO: This needs some lemmas describing the produced adjunction, probably in terms of `adj`,
-- `iC` and `iD`.
/--
If `C` is a full subcategory of `C'` and `D` is a full subcategory of `D'`, then we can restrict
an adjunction `L' ⊣ R'` where `L' : C' ⥤ D'` and `R' : D' ⥤ C'` to `C` and `D`.
The construction here is slightly more general, in that `C` is required only to have a full and
faithful "inclusion" functor `iC : C ⥤ C'` (and similarly `iD : D ⥤ D'`) which commute (up to
natural isomorphism) with the proposed restrictions.
-/
def adjunction.restrict_fully_faithful (iC : C ⥤ C') (iD : D ⥤ D') {L' : C' ⥤ D'} {R' : D' ⥤ C'}
  (adj : L' ⊣ R') {L : C ⥤ D} {R : D ⥤ C} (comm1 : iC ⋙ L' ≅ L ⋙ iD) (comm2 : iD ⋙ R' ≅ R ⋙ iC)
  [full iC] [faithful iC] [full iD] [faithful iD] :
  L ⊣ R :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y,
  calc (L.obj X ⟶ Y) ≃ (iD.obj (L.obj X) ⟶ iD.obj Y) : equiv_of_fully_faithful iD
       ... ≃ (L'.obj (iC.obj X) ⟶ iD.obj Y) : iso.hom_congr (comm1.symm.app X) (iso.refl _)
       ... ≃ (iC.obj X ⟶ R'.obj (iD.obj Y)) : adj.hom_equiv _ _
       ... ≃ (iC.obj X ⟶ iC.obj (R.obj Y)) : iso.hom_congr (iso.refl _) (comm2.app Y)
       ... ≃ (X ⟶ R.obj Y) : (equiv_of_fully_faithful iC).symm,
  hom_equiv_naturality_left_symm' := λ X' X Y f g,
  begin
    apply iD.map_injective,
    simpa using (comm1.inv.naturality_assoc f _).symm,
  end,
  hom_equiv_naturality_right' := λ X Y' Y f g,
  begin
    apply iC.map_injective,
    suffices : R'.map (iD.map g) ≫ comm2.hom.app Y = comm2.hom.app Y' ≫ iC.map (R.map g),
      simp [this],
    apply comm2.hom.naturality g,
  end }

end category_theory


import condensed.is_proetale_sheaf
import condensed.top_comparison
import condensed.adjunctions

/-!
We show that passing from a profinite set to a condensed set
preserves (finite) coproducts.
-/

open_locale big_operators classical
open category_theory
open category_theory.limits
open opposite

universe u

namespace Profinite

@[simps]
def to_Condensed_equiv (X : Profinite.{u}) (Y : CondensedSet.{u}) :
  (X.to_Condensed ⟶ Y) ≃ Y.val.obj (op X) :=
{ to_fun := λ f, f.val.app _ $ ulift.up $ 𝟙 _,
  inv_fun := λ f, Sheaf.hom.mk $
  { app := λ T g, Y.val.map (quiver.hom.op (ulift.down g)) f,
    naturality' := begin
      intros A B ff, ext t,
      obtain ⟨t⟩ := t,
      dsimp [Profinite.to_Condensed, ulift_functor, yoneda] at ⊢ t,
      simp only [functor.map_comp], refl,
    end },
  left_inv := λ f, begin
    ext T ⟨t⟩,
    dsimp [yoneda] at ⊢ t,
    change (f.val.app _ ≫ Y.val.map _) _ = _,
    rw ← nat_trans.naturality,
    change f.val.app _ _ = _,
    congr' 1, ext, refl,
  end,
  right_inv := λ f, by { dsimp, simp } }

end Profinite

namespace CondensedSet

variables {α : Type u} [fintype α] (X : α → Profinite.{u})

@[simps]
def sigma_cone : cocone (discrete.functor X ⋙ Profinite_to_Condensed) :=
{ X := (Profinite.sigma X).to_Condensed,
  ι :=
  { app := λ i, Profinite_to_Condensed.map $ Profinite.sigma.ι X i.1,
    naturality' := begin
      rintros ⟨i⟩ ⟨j⟩ ⟨⟨⟨⟩⟩⟩, dsimp, simp, dsimp, simp, dsimp, simp,
    end } } .

noncomputable
def val_obj_sigma_equiv (Y : CondensedSet.{u}) :
  Y.val.obj (op $ Profinite.sigma X) ≃ (Π (a : α), Y.val.obj (op $ X a)) :=
equiv.of_bijective
(λ f a, Y.val.map (Profinite.sigma.ι X a).op f)
begin
  have := Y.2,
  rw is_sheaf_iff_is_sheaf_of_type at this,
  rw Y.val.is_proetale_sheaf_of_types_tfae.out 0 4 at this,
  have key := this.1,
  exact key ⟨α⟩ X,
end

noncomputable
def _root_.Condensed.val_obj_sigma_add_equiv
  (Y : Condensed.{u} Ab.{u+1}) :
  Y.val.obj (op $ Profinite.sigma X) ≃+
  (Π (a : α), Y.val.obj (op $ X a)) :=
add_equiv.of_bijective
(add_monoid_hom.mk' (λ f a, Y.val.map (Profinite.sigma.ι X a).op f) (by { intros, ext1, simp }))
((Condensed_Ab_to_CondensedSet.obj Y).val_obj_sigma_equiv X).bijective

@[simp]
lemma coe_val_obj_sigma_equiv (Y : Condensed.{u} Ab.{u+1}) :
  ⇑((Condensed_Ab_to_CondensedSet.obj Y).val_obj_sigma_equiv X) =
  (Y.val_obj_sigma_add_equiv X) := rfl

@[simp]
lemma coe_val_obj_sigma_equiv_symm (Y : Condensed.{u} Ab.{u+1}) :
  ⇑((Condensed_Ab_to_CondensedSet.obj Y).val_obj_sigma_equiv X).symm =
  (Y.val_obj_sigma_add_equiv X).symm := rfl

@[simp]
lemma _root_.Condensed.val_obj_sigma_add_equiv_apply_apply
  (Y : Condensed.{u} Ab.{u+1}) (t) (a) :
  Y.val_obj_sigma_add_equiv X t a = Y.val.map (Profinite.sigma.ι X a).op t := rfl

lemma val_obj_sigma_equiv_symm_apply'
  (Y : CondensedSet.{u})
  (e : Π (a : α), Y.val.obj (op $ X a)) (a₀ : α) :
  (Y.val.map (Profinite.sigma.ι X a₀).op)
  (((val_obj_sigma_equiv X Y).symm) e) = e a₀ :=
begin
  let e' := _, change (Y.val.map (Profinite.sigma.ι X a₀).op) e' = _,
  have : e a₀ = (val_obj_sigma_equiv X Y) e' a₀,
    { revert a₀, rw ← function.funext_iff, dsimp only [e'], simp },
  rw this, refl,
end

-- TODO reuse the nonadditive variant for this.
lemma _root_.Condensed.val_obj_sigma_add_equiv_symm_apply'
  (Y : Condensed.{u} Ab.{u+1})
  (e : Π (a : α), Y.val.obj (op $ X a)) (a₀ : α) :
  (Y.val.map (Profinite.sigma.ι X a₀).op)
  (((_root_.Condensed.val_obj_sigma_add_equiv X Y).symm) e) = e a₀ :=
begin
  let e' := _, change (Y.val.map (Profinite.sigma.ι X a₀).op) e' = _,
  have : e a₀ = (_root_.Condensed.val_obj_sigma_add_equiv X Y) e' a₀,
    { revert a₀, rw ← function.funext_iff, dsimp only [e'], simp },
  rw this, refl,
end

lemma val_obj_sigma_equiv_symm_apply
  (Y : CondensedSet.{u})
  (e : Π (a : α), Y.val.obj (op $ X a)) (a₀ : α) :
    (Profinite_to_Condensed.map (Profinite.sigma.ι X a₀)) ≫
    (Profinite.to_Condensed_equiv (Profinite.sigma X) Y).symm
    ((Y.val_obj_sigma_equiv X).symm e) =
    (Profinite.to_Condensed_equiv (X a₀) Y).symm (e a₀) :=
begin
  apply_fun ((X a₀).to_Condensed_equiv Y),
  simp only [equiv.apply_symm_apply],
  dsimp [Profinite.to_Condensed_equiv],
  simp only [category.comp_id],
  apply val_obj_sigma_equiv_symm_apply'
end

-- TODO reuse the nonadditive variant for this.
lemma _root_.Condensed.val_obj_sigma_add_equiv_symm_apply
  (Y : Condensed.{u} Ab.{u+1})
  (e : Π (a : α), Y.val.obj (op $ X a)) (a₀ : α) :
    (Profinite_to_Condensed.map (Profinite.sigma.ι X a₀)) ≫
    (Profinite.to_Condensed_equiv (Profinite.sigma X)
    (Condensed_Ab_to_CondensedSet.obj Y)).symm
    ((Y.val_obj_sigma_add_equiv X).symm e) =
    (Profinite.to_Condensed_equiv (X a₀)
    (Condensed_Ab_to_CondensedSet.obj Y)).symm (e a₀) :=
begin
  apply_fun ((X a₀).to_Condensed_equiv (Condensed_Ab_to_CondensedSet.obj Y)),
  simp only [equiv.apply_symm_apply],
  dsimp [Profinite.to_Condensed_equiv],
  simp only [category.comp_id],
  apply _root_.Condensed.val_obj_sigma_add_equiv_symm_apply'
end

noncomputable
def is_colimit_sigma_cone : is_colimit (sigma_cone X) :=
{ desc := λ S, (Profinite.to_Condensed_equiv _ _).symm $
    (S.X.val_obj_sigma_equiv X).symm $ λ a,
    (Profinite.to_Condensed_equiv _ _) $ S.ι.app ⟨_⟩,
  fac' := begin
    rintros Q ⟨T⟩,
    dsimp,
    rw val_obj_sigma_equiv_symm_apply,
    ext W ⟨(t : _ ⟶ _)⟩,
    dsimp [Profinite.to_Condensed_equiv],
    change ((Q.ι.app ⟨T⟩).val.app (op (X T)) ≫ Q.X.val.map t.op) _ = _,
    erw ← (Q.ι.app ⟨T⟩).val.naturality,
    change (Q.ι.app ⟨T⟩).val.app (op (unop W)) _ = _,
    congr' 1,
    dsimp [Profinite.to_Condensed], ext, refl,
  end,
  uniq' := begin
    intros S m hm,
    apply_fun ((Profinite.sigma X).to_Condensed_equiv S.X),
    apply_fun (val_obj_sigma_equiv X S.X),
    simp only [equiv.apply_symm_apply],
    ext a,
    specialize hm ⟨a⟩,
    dsimp [val_obj_sigma_equiv],
    change (m.val.app (op (Profinite.sigma X)) ≫
      S.X.val.map _) _ = _,
    rw ← m.val.naturality,
    apply_fun (λ e, e.val.app (op (X a)) ⟨𝟙 _⟩) at hm,
    exact hm,
  end }

end CondensedSet


/-
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.category_theory.monoidal.discrete
import Mathlib.category_theory.monoidal.unitors
import Mathlib.category_theory.limits.shapes.terminal
import Mathlib.algebra.punit_instances
import Mathlib.PostPort

universes v₁ u₁ l u₂ v₂ u_1 u_2

namespace Mathlib

/-!
# The category of monoids in a monoidal category.
-/

/--
A monoid object internal to a monoidal category.

When the monoidal category is preadditive, this is also sometimes called an "algebra object".
-/
structure Mon_ (C : Type u₁) [category_theory.category C] [category_theory.monoidal_category C]
where
  X : C
  one : 𝟙_ ⟶ X
  mul : X ⊗ X ⟶ X
  one_mul' : autoParam ((one ⊗ 𝟙) ≫ mul = category_theory.iso.hom λ_)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  mul_one' : autoParam ((𝟙 ⊗ one) ≫ mul = category_theory.iso.hom ρ_)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  mul_assoc' : autoParam ((mul ⊗ 𝟙) ≫ mul = category_theory.iso.hom α_ ≫ (𝟙 ⊗ mul) ≫ mul)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

-- Obviously there is some flexibility stating this axiom.

-- This one has left- and right-hand sides matching the statement of `monoid.mul_assoc`,

-- and chooses to place the associator on the right-hand side.

-- The heuristic is that unitors and associators "don't have much weight".

theorem Mon_.one_mul {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] (c : Mon_ C) : (Mon_.one c ⊗ 𝟙) ≫ Mon_.mul c = category_theory.iso.hom λ_ := sorry

theorem Mon_.mul_one {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] (c : Mon_ C) : (𝟙 ⊗ Mon_.one c) ≫ Mon_.mul c = category_theory.iso.hom ρ_ := sorry

@[simp] theorem Mon_.mul_assoc {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] (c : Mon_ C) : (Mon_.mul c ⊗ 𝟙) ≫ Mon_.mul c = category_theory.iso.hom α_ ≫ (𝟙 ⊗ Mon_.mul c) ≫ Mon_.mul c := sorry

theorem Mon_.one_mul_assoc {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] (c : Mon_ C) {X' : C} (f' : Mon_.X c ⟶ X') : (Mon_.one c ⊗ 𝟙) ≫ Mon_.mul c ≫ f' = category_theory.iso.hom λ_ ≫ f' := sorry

@[simp] theorem Mon_.mul_assoc_assoc {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] (c : Mon_ C) {X' : C} (f' : Mon_.X c ⟶ X') : (Mon_.mul c ⊗ 𝟙) ≫ Mon_.mul c ≫ f' = category_theory.iso.hom α_ ≫ (𝟙 ⊗ Mon_.mul c) ≫ Mon_.mul c ≫ f' := sorry

namespace Mon_

/--
The trivial monoid object. We later show this is initial in `Mon_ C`.
-/
@[simp] theorem trivial_one (C : Type u₁) [category_theory.category C] [category_theory.monoidal_category C] : one (trivial C) = 𝟙 :=
  Eq.refl (one (trivial C))

protected instance inhabited (C : Type u₁) [category_theory.category C] [category_theory.monoidal_category C] : Inhabited (Mon_ C) :=
  { default := trivial C }

@[simp] theorem one_mul_hom {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {M : Mon_ C} {Z : C} (f : Z ⟶ X M) : (one M ⊗ f) ≫ mul M = category_theory.iso.hom λ_ ≫ f := sorry

@[simp] theorem mul_one_hom {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {M : Mon_ C} {Z : C} (f : Z ⟶ X M) : (f ⊗ one M) ≫ mul M = category_theory.iso.hom ρ_ ≫ f := sorry

theorem assoc_flip {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {M : Mon_ C} : (𝟙 ⊗ mul M) ≫ mul M = category_theory.iso.inv α_ ≫ (mul M ⊗ 𝟙) ≫ mul M := sorry

/-- A morphism of monoid objects. -/
structure hom {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] (M : Mon_ C) (N : Mon_ C)
where
  hom : X M ⟶ X N
  one_hom' : autoParam (one M ≫ hom = one N)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  mul_hom' : autoParam (mul M ≫ hom = (hom ⊗ hom) ≫ mul N)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

@[simp] theorem hom.one_hom {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {M : Mon_ C} {N : Mon_ C} (c : hom M N) : one M ≫ hom.hom c = one N := sorry

@[simp] theorem hom.mul_hom {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {M : Mon_ C} {N : Mon_ C} (c : hom M N) : mul M ≫ hom.hom c = (hom.hom c ⊗ hom.hom c) ≫ mul N := sorry

@[simp] theorem hom.mul_hom_assoc {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {M : Mon_ C} {N : Mon_ C} (c : hom M N) {X' : C} (f' : X N ⟶ X') : mul M ≫ hom.hom c ≫ f' = (hom.hom c ⊗ hom.hom c) ≫ mul N ≫ f' := sorry

/-- The identity morphism on a monoid object. -/
def id {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] (M : Mon_ C) : hom M M :=
  hom.mk 𝟙

protected instance hom_inhabited {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] (M : Mon_ C) : Inhabited (hom M M) :=
  { default := id M }

/-- Composition of morphisms of monoid objects. -/
@[simp] theorem comp_hom {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {M : Mon_ C} {N : Mon_ C} {O : Mon_ C} (f : hom M N) (g : hom N O) : hom.hom (comp f g) = hom.hom f ≫ hom.hom g :=
  Eq.refl (hom.hom (comp f g))

protected instance category_theory.category {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] : category_theory.category (Mon_ C) :=
  category_theory.category.mk

@[simp] theorem id_hom' {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] (M : Mon_ C) : hom.hom 𝟙 = 𝟙 :=
  rfl

@[simp] theorem comp_hom' {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {M : Mon_ C} {N : Mon_ C} {K : Mon_ C} (f : M ⟶ N) (g : N ⟶ K) : hom.hom (f ≫ g) = hom.hom f ≫ hom.hom g :=
  rfl

/-- The forgetful functor from monoid objects to the ambient category. -/
@[simp] theorem forget_map (C : Type u₁) [category_theory.category C] [category_theory.monoidal_category C] (A : Mon_ C) (B : Mon_ C) (f : A ⟶ B) : category_theory.functor.map (forget C) f = hom.hom f :=
  Eq.refl (category_theory.functor.map (forget C) f)

protected instance forget_faithful {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] : category_theory.faithful (forget C) :=
  category_theory.faithful.mk

protected instance category_theory.has_hom.hom.hom.category_theory.is_iso {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] {A : Mon_ C} {B : Mon_ C} (f : A ⟶ B) [e : category_theory.is_iso (category_theory.functor.map (forget C) f)] : category_theory.is_iso (hom.hom f) :=
  e

/-- The forgetful functor from monoid objects to the ambient category reflects isomorphisms. -/
protected instance forget.category_theory.reflects_isomorphisms {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] : category_theory.reflects_isomorphisms (forget C) :=
  category_theory.reflects_isomorphisms.mk
    fun (X Y : Mon_ C) (f : X ⟶ Y) (e : category_theory.is_iso (category_theory.functor.map (forget C) f)) =>
      category_theory.is_iso.mk (hom.mk (inv (hom.hom f)))

protected instance unique_hom_from_trivial {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] (A : Mon_ C) : unique (trivial C ⟶ A) :=
  unique.mk { default := hom.mk (one A) } sorry

protected instance category_theory.limits.has_initial {C : Type u₁} [category_theory.category C] [category_theory.monoidal_category C] : category_theory.limits.has_initial (Mon_ C) :=
  category_theory.limits.has_initial_of_unique (trivial C)

end Mon_

namespace category_theory.lax_monoidal_functor

/--
A lax monoidal functor takes monoid objects to monoid objects.

That is, a lax monoidal functor `F : C ⥤ D` induces a functor `Mon_ C ⥤ Mon_ D`.
-/
-- TODO: map_Mod F A : Mod A ⥤ Mod (F.map_Mon A)

@[simp] theorem map_Mon_obj_X {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] [monoidal_category D] (F : lax_monoidal_functor C D) (A : Mon_ C) : Mon_.X (functor.obj (map_Mon F) A) = functor.obj (to_functor F) (Mon_.X A) :=
  Eq.refl (Mon_.X (functor.obj (map_Mon F) A))

/-- `map_Mon` is functorial in the lax monoidal functor. -/
def map_Mon_functor (C : Type u₁) [category C] [monoidal_category C] (D : Type u₂) [category D] [monoidal_category D] : lax_monoidal_functor C D ⥤ Mon_ C ⥤ Mon_ D :=
  functor.mk map_Mon
    fun (F G : lax_monoidal_functor C D) (α : F ⟶ G) =>
      nat_trans.mk fun (A : Mon_ C) => Mon_.hom.mk (nat_trans.app (monoidal_nat_trans.to_nat_trans α) (Mon_.X A))

end category_theory.lax_monoidal_functor

namespace Mon_

namespace equiv_lax_monoidal_functor_punit

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
def lax_monoidal_to_Mon (C : Type u₁) [category_theory.category C] [category_theory.monoidal_category C] : category_theory.lax_monoidal_functor (category_theory.discrete PUnit) C ⥤ Mon_ C :=
  category_theory.functor.mk
    (fun (F : category_theory.lax_monoidal_functor (category_theory.discrete PUnit) C) =>
      category_theory.functor.obj (category_theory.lax_monoidal_functor.map_Mon F)
        (trivial (category_theory.discrete PUnit)))
    fun (F G : category_theory.lax_monoidal_functor (category_theory.discrete PUnit) C) (α : F ⟶ G) =>
      category_theory.nat_trans.app
        (category_theory.functor.map
          (category_theory.lax_monoidal_functor.map_Mon_functor (category_theory.discrete PUnit) C) α)
        (trivial (category_theory.discrete PUnit))

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
def Mon_to_lax_monoidal (C : Type u₁) [category_theory.category C] [category_theory.monoidal_category C] : Mon_ C ⥤ category_theory.lax_monoidal_functor (category_theory.discrete PUnit) C :=
  category_theory.functor.mk
    (fun (A : Mon_ C) =>
      category_theory.lax_monoidal_functor.mk
        (category_theory.functor.mk (fun (_x : category_theory.discrete PUnit) => X A)
          fun (_x _x_1 : category_theory.discrete PUnit) (_x : _x ⟶ _x_1) => 𝟙)
        (one A) fun (_x _x : category_theory.discrete PUnit) => mul A)
    fun (A B : Mon_ C) (f : A ⟶ B) =>
      category_theory.monoidal_nat_trans.mk
        (category_theory.nat_trans.mk fun (_x : category_theory.discrete PUnit) => hom.hom f)

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
@[simp] theorem unit_iso_inv_app_to_nat_trans_app (C : Type u₁) [category_theory.category C] [category_theory.monoidal_category C] (X : category_theory.lax_monoidal_functor (category_theory.discrete PUnit) C) : ∀ (X_1 : category_theory.discrete PUnit),
  category_theory.nat_trans.app
      (category_theory.monoidal_nat_trans.to_nat_trans
        (category_theory.nat_trans.app (category_theory.iso.inv (unit_iso C)) X))
      X_1 =
    inv
      (category_theory.eq_to_hom
        (congr_arg (category_theory.functor.obj (category_theory.lax_monoidal_functor.to_functor X))
          (unit_iso._proof_1 X_1))) := sorry

/-- Implementation of `Mon_.equiv_lax_monoidal_functor_punit`. -/
@[simp] theorem counit_iso_inv_app_hom (C : Type u₁) [category_theory.category C] [category_theory.monoidal_category C] (X : Mon_ C) : hom.hom (category_theory.nat_trans.app (category_theory.iso.inv (counit_iso C)) X) = 𝟙 :=
  Eq.refl 𝟙

end equiv_lax_monoidal_functor_punit

/--
Monoid objects in `C` are "just" lax monoidal functors from the trivial monoidal category to `C`.
-/
def equiv_lax_monoidal_functor_punit (C : Type u₁) [category_theory.category C] [category_theory.monoidal_category C] : category_theory.lax_monoidal_functor (category_theory.discrete PUnit) C ≌ Mon_ C :=
  category_theory.equivalence.mk' sorry sorry sorry sorry


/-
Copyright (c) 2017 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import tactic.ext
import tactic.lint

/-!
# Functors

This module provides additional lemmas, definitions, and instances for `functor`s.

## Main definitions

* `const α` is the functor that sends all types to `α`.
* `add_const α` is `const α` but for when `α` has an additive structure.
* `comp F G` for functors `F` and `G` is the functor composition of `F` and `G`.
* `liftp` and `liftr` respectively lift predicates and relations on a type `α`
  to `F α`.  Terms of `F α` are considered to, in some sense, contain values of type `α`.

## Tags

functor, applicative
-/

attribute [functor_norm] seq_assoc pure_seq_eq_map map_pure seq_map_assoc map_seq

universes u v w

section functor

variables {F : Type u → Type v}
variables {α β γ : Type u}
variables [functor F] [is_lawful_functor F]

lemma functor.map_id : (<$>) id = (id : F α → F α) :=
by apply funext; apply id_map

lemma functor.map_comp_map (f : α → β) (g : β → γ) :
  ((<$>) g ∘ (<$>) f : F α → F γ) = (<$>) (g ∘ f) :=
by apply funext; intro; rw comp_map

theorem functor.ext {F} : ∀ {F1 : functor F} {F2 : functor F}
  [@is_lawful_functor F F1] [@is_lawful_functor F F2]
  (H : ∀ α β (f : α → β) (x : F α),
    @functor.map _ F1 _ _ f x = @functor.map _ F2 _ _ f x),
  F1 = F2
| ⟨m, mc⟩ ⟨m', mc'⟩ H1 H2 H :=
begin
  cases show @m = @m', by funext α β f x; apply H,
  congr, funext α β,
  have E1 := @map_const_eq _ ⟨@m, @mc⟩ H1,
  have E2 := @map_const_eq _ ⟨@m, @mc'⟩ H2,
  exact E1.trans E2.symm
end

end functor

/-- Introduce the `id` functor. Incidentally, this is `pure` for
`id` as a `monad` and as an `applicative` functor. -/
def id.mk {α : Sort u} : α → id α := id

namespace functor

/-- `const α` is the constant functor, mapping every type to `α`. When
`α` has a monoid structure, `const α` has an `applicative` instance.
(If `α` has an additive monoid structure, see `functor.add_const`.) -/
@[nolint unused_arguments]
def const (α : Type*) (β : Type*) := α

/-- `const.mk` is the canonical map `α → const α β` (the identity), and
it can be used as a pattern to extract this value. -/
@[pattern] def const.mk {α β} (x : α) : const α β := x

/-- `const.mk'` is `const.mk` but specialized to map `α` to
`const α punit`, where `punit` is the terminal object in `Type*`. -/
def const.mk' {α} (x : α) : const α punit := x

/-- Extract the element of `α` from the `const` functor. -/
def const.run {α β} (x : const α β) : α := x

namespace const

protected lemma ext {α β} {x y : const α β} (h : x.run = y.run) : x = y := h

/-- The map operation of the `const γ` functor. -/
@[nolint unused_arguments]
protected def map {γ α β} (f : α → β) (x : const γ β) : const γ α := x

instance {γ} : functor (const γ) :=
{ map := @const.map γ }

instance {γ} : is_lawful_functor (const γ) :=
by constructor; intros; refl

instance {α β} [inhabited α] : inhabited (const α β) :=
⟨(default _ : α)⟩

end const

/-- `add_const α` is a synonym for constant functor `const α`, mapping
every type to `α`. When `α` has a additive monoid structure,
`add_const α` has an `applicative` instance. (If `α` has a
multiplicative monoid structure, see `functor.const`.) -/
def add_const (α : Type*) := const α

/-- `add_const.mk` is the canonical map `α → add_const α β`, which is the identity,
where `add_const α β = const α β`. It can be used as a pattern to extract this value. -/
@[pattern]
def add_const.mk {α β} (x : α) : add_const α β := x

/-- Extract the element of `α` from the constant functor. -/
def add_const.run {α β} : add_const α β → α := id

instance add_const.functor {γ} : functor (add_const γ) :=
@const.functor γ

instance add_const.is_lawful_functor {γ} : is_lawful_functor (add_const γ) :=
@const.is_lawful_functor γ

instance {α β} [inhabited α] : inhabited (add_const α β) :=
⟨(default _ : α)⟩

/-- `functor.comp` is a wrapper around `function.comp` for types.
    It prevents Lean's type class resolution mechanism from trying
    a `functor (comp F id)` when `functor F` would do. -/
def comp (F : Type u → Type w) (G : Type v → Type u) (α : Type v) : Type w :=
F $ G α

/-- Construct a term of `comp F G α` from a term of `F (G α)`, which is the same type.
Can be used as a pattern to extract a term of `F (G α)`. -/
@[pattern] def comp.mk {F : Type u → Type w} {G : Type v → Type u} {α : Type v}
  (x : F (G α)) : comp F G α := x

/-- Extract a term of `F (G α)` from a term of `comp F G α`, which is the same type. -/
def comp.run {F : Type u → Type w} {G : Type v → Type u} {α : Type v}
  (x : comp F G α) : F (G α) := x

namespace comp

variables {F : Type u → Type w} {G : Type v → Type u}

protected lemma ext
  {α} {x y : comp F G α} : x.run = y.run → x = y := id

instance {α} [inhabited (F (G α))] : inhabited (comp F G α) :=
⟨(default _ : F (G α))⟩

variables [functor F] [functor G]

/-- The map operation for the composition `comp F G` of functors `F` and `G`. -/
protected def map {α β : Type v} (h : α → β) : comp F G α → comp F G β
| (comp.mk x) := comp.mk ((<$>) h <$> x)

instance : functor (comp F G) := { map := @comp.map F G _ _ }

@[functor_norm] lemma map_mk {α β} (h : α → β) (x : F (G α)) :
  h <$> comp.mk x = comp.mk ((<$>) h <$> x) := rfl

@[simp] protected lemma run_map {α β} (h : α → β) (x : comp F G α) :
  (h <$> x).run = (<$>) h <$> x.run := rfl

variables [is_lawful_functor F] [is_lawful_functor G]
variables {α β γ : Type v}

protected lemma id_map : ∀ (x : comp F G α), comp.map id x = x
| (comp.mk x) := by simp [comp.map, functor.map_id]

protected lemma comp_map (g' : α → β) (h : β → γ) : ∀ (x : comp F G α),
           comp.map (h ∘ g') x = comp.map h (comp.map g' x)
| (comp.mk x) := by simp [comp.map, functor.map_comp_map g' h] with functor_norm

instance : is_lawful_functor (comp F G) :=
{ id_map := @comp.id_map F G _ _ _ _,
  comp_map := @comp.comp_map F G _ _ _ _ }

theorem functor_comp_id {F} [AF : functor F] [is_lawful_functor F] :
  @comp.functor F id _ _ = AF :=
@functor.ext F _ AF (@comp.is_lawful_functor F id _ _ _ _) _ (λ α β f x, rfl)

theorem functor_id_comp {F} [AF : functor F] [is_lawful_functor F] :
  @comp.functor id F _ _ = AF :=
@functor.ext F _ AF (@comp.is_lawful_functor id F _ _ _ _) _ (λ α β f x, rfl)

end comp

namespace comp

open function (hiding comp)
open functor

variables {F : Type u → Type w} {G : Type v → Type u}

variables [applicative F] [applicative G]

/-- The `<*>` operation for the composition of applicative functors. -/
protected def seq {α β : Type v} : comp F G (α → β) → comp F G α → comp F G β
| (comp.mk f) (comp.mk x) := comp.mk $ (<*>) <$> f <*> x

instance : has_pure (comp F G) :=
⟨λ _ x, comp.mk $ pure $ pure x⟩

instance : has_seq (comp F G) :=
⟨λ _ _ f x, comp.seq f x⟩

@[simp] protected lemma run_pure {α : Type v} :
  ∀ x : α, (pure x : comp F G α).run = pure (pure x)
| _ := rfl

@[simp] protected lemma run_seq {α β : Type v} (f : comp F G (α → β)) (x : comp F G α) :
  (f <*> x).run = (<*>) <$> f.run <*> x.run := rfl

instance : applicative (comp F G) :=
{ map := @comp.map F G _ _,
  seq := @comp.seq F G _ _,
  ..comp.has_pure }

end comp

variables {F : Type u → Type u} [functor F]

/-- If we consider `x : F α` to, in some sense, contain values of type `α`,
predicate `liftp p x` holds iff every value contained by `x` satisfies `p`. -/
def liftp {α : Type u} (p : α → Prop) (x : F α) : Prop :=
∃ u : F (subtype p), subtype.val <$> u = x

/-- If we consider `x : F α` to, in some sense, contain values of type `α`, then
`liftr r x y` relates `x` and `y` iff (1) `x` and `y` have the same shape and
(2) we can pair values `a` from `x` and `b` from `y` so that `r a b` holds. -/
def liftr {α : Type u} (r : α → α → Prop) (x y : F α) : Prop :=
∃ u : F {p : α × α // r p.fst p.snd},
  (λ t : {p : α × α // r p.fst p.snd}, t.val.fst) <$> u = x ∧
  (λ t : {p : α × α // r p.fst p.snd}, t.val.snd) <$> u = y

/-- If we consider `x : F α` to, in some sense, contain values of type `α`, then
`supp x` is the set of values of type `α` that `x` contains. -/
def supp {α : Type u} (x : F α) : set α := { y : α | ∀ ⦃p⦄, liftp p x → p y }

theorem of_mem_supp {α : Type u} {x : F α} {p : α → Prop} (h : liftp p x) :
  ∀ y ∈ supp x, p y :=
λ y hy, hy h

end functor