import logic.idecidable

--- Statement of definite description
axiom definite_description {α : Sort _} {p : α → Prop} : (∃! (a : α), p a) → {a:α // p a}

namespace unsafe

--- `definite_description` enables choice on subsingleton types.
noncomputable definition subsingleton_choice (α : Sort _) [subsingleton α] : nonempty α → α :=
  λ h, subtype.val ∘ @definite_description α (λ _, true) $
    by cases h with a; existsi a; split; try {trivial};
       dsimp *; intros y _; exact subsingleton.elim y a

--- Turn the "internal" decidablility into the "external" one.
noncomputable definition decidable_of_idecidable (p : Prop) [idecidable p] : decidable p :=
  subsingleton_choice (decidable p) $
    begin
      cases whether p with hp hnp,
      case or.inl {
        constructor,
        exact is_true hp,
      },
      case or.inr {
        constructor,
        exact is_false hnp,
      }
    end

lemma dec_of_idec_pos {p : Prop} [idecidable p] : Π (h : p), decidable_of_idecidable p = is_true h :=
  begin
    intros h,
    cases decidable_of_idecidable p with hnp hp,
    case is_false { exfalso; exact hnp h },
    case is_true { refl }
  end

lemma dec_of_idec_neg {p : Prop} [idecidable p] : Π (h : ¬p), decidable_of_idecidable p = is_false h :=
  begin
    intros h,
    cases decidable_of_idecidable p with hnp hp,
    case is_false { refl },
    case is_true { exfalso; exact h hp }
  end

end unsafe


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro

Parallel computation of a computable sequence of computations by
a diagonal enumeration.
The important theorems of this operation are proven as
terminates_parallel and exists_of_mem_parallel.
(This operation is nondeterministic in the sense that it does not
honor sequence equivalence (irrelevance of computation time).)
-/
import data.seq.wseq
universes u v

namespace computation
open wseq
variables {α : Type u} {β : Type v}

def parallel.aux2 : list (computation α) → α ⊕ list (computation α) :=
list.foldr (λc o, match o with
| sum.inl a  := sum.inl a
| sum.inr ls := rmap (λ c', c' :: ls) (destruct c)
end) (sum.inr [])

def parallel.aux1 : list (computation α) × wseq (computation α) →
  α ⊕ list (computation α) × wseq (computation α)
| (l, S) := rmap (λ l', match seq.destruct S with
  | none := (l', nil)
  | some (none, S') := (l', S')
  | some (some c, S') := (c::l', S')
  end) (parallel.aux2 l)

/-- Parallel computation of an infinite stream of computations,
  taking the first result -/
def parallel (S : wseq (computation α)) : computation α :=
corec parallel.aux1 ([], S)

theorem terminates_parallel.aux : ∀ {l : list (computation α)} {S c},
  c ∈ l → terminates c → terminates (corec parallel.aux1 (l, S)) :=
begin
  have lem1 : ∀ l S, (∃ (a : α), parallel.aux2 l = sum.inl a) →
    terminates (corec parallel.aux1 (l, S)),
  { intros l S e, cases e with a e,
    have this : corec parallel.aux1 (l, S) = return a,
    { apply destruct_eq_ret, simp [parallel.aux1], rw e, simp [rmap] },
    rw this, apply_instance },
  intros l S c m T, revert l S,
  apply @terminates_rec_on _ _ c T _ _,
  { intros a l S m, apply lem1,
    induction l with c l IH generalizing m; simp at m, { contradiction },
    cases m with e m,
    { rw ←e, simp [parallel.aux2],
      cases list.foldr parallel.aux2._match_1 (sum.inr list.nil) l with a' ls,
      exacts [⟨a', rfl⟩, ⟨a, rfl⟩] },
    { cases IH m with a' e,
      simp [parallel.aux2], simp [parallel.aux2] at e,
      rw e, exact ⟨a', rfl⟩ } },
  { intros s IH l S m,
    have H1 : ∀ l', parallel.aux2 l = sum.inr l' → s ∈ l',
    { induction l with c l IH' generalizing m;
      intros l' e'; simp at m, { contradiction },
      cases m with e m; simp [parallel.aux2] at e',
      { rw ←e at e',
        cases list.foldr parallel.aux2._match_1 (sum.inr list.nil) l with a' ls;
        injection e' with e', rw ←e', simp },
      { induction e : list.foldr parallel.aux2._match_1 (sum.inr list.nil) l with a' ls;
        rw e at e', { contradiction },
        have := IH' m _ e,
        simp [parallel.aux2] at e',
        cases destruct c; injection e' with h',
        rw ←h', simp [this] } },
    induction h : parallel.aux2 l with a l',
    { exact lem1 _ _ ⟨a, h⟩ },
    { have H2 : corec parallel.aux1 (l, S) = think _,
      { apply destruct_eq_think,
        simp [parallel.aux1],
        rw h, simp [rmap] },
      rw H2, apply @computation.think_terminates _ _ _,
      have := H1 _ h,
      rcases seq.destruct S with _ | ⟨_|c, S'⟩;
      simp [parallel.aux1]; apply IH; simp [this] } }
end

theorem terminates_parallel {S : wseq (computation α)}
   {c} (h : c ∈ S) [T : terminates c] : terminates (parallel S) :=
suffices ∀ n (l : list (computation α)) S c,
  c ∈ l ∨ some (some c) = seq.nth S n →
  terminates c → terminates (corec parallel.aux1 (l, S)),
from let ⟨n, h⟩ := h in this n [] S c (or.inr h) T,
begin
  intro n, induction n with n IH; intros l S c o T,
  { cases o with a a, { exact terminates_parallel.aux a T },
    have H : seq.destruct S = some (some c, _),
    { unfold seq.destruct functor.map, rw ← a, simp },
    induction h : parallel.aux2 l with a l';
    have C : corec parallel.aux1 (l, S) = _,
    { apply destruct_eq_ret, simp [parallel.aux1], rw [h], simp [rmap] },
    { rw C, resetI, apply_instance },
    { apply destruct_eq_think, simp [parallel.aux1], rw [h, H], simp [rmap] },
    { rw C, apply @computation.think_terminates _ _ _,
      apply terminates_parallel.aux _ T, simp } },
  { cases o with a a, { exact terminates_parallel.aux a T },
    induction h : parallel.aux2 l with a l';
    have C : corec parallel.aux1 (l, S) = _,
    { apply destruct_eq_ret, simp [parallel.aux1], rw [h], simp [rmap] },
    { rw C, resetI, apply_instance },
    { apply destruct_eq_think, simp [parallel.aux1], rw [h], simp [rmap] },
    { rw C, apply @computation.think_terminates _ _ _,
      have TT : ∀ l', terminates (corec parallel.aux1 (l', S.tail)),
      { intro, apply IH _ _ _ (or.inr _) T, rw a, cases S with f al, refl },
      induction e : seq.nth S 0 with o,
      { have D : seq.destruct S = none,
        { dsimp [seq.destruct], rw e, refl },
        rw D, simp [parallel.aux1], have TT := TT l',
        rwa [seq.destruct_eq_nil D, seq.tail_nil] at TT },
      { have D : seq.destruct S = some (o, S.tail),
        { dsimp [seq.destruct], rw e, refl },
        rw D, cases o with c; simp [parallel.aux1, TT] } } }
end

theorem exists_of_mem_parallel {S : wseq (computation α)}
   {a} (h : a ∈ parallel S) : ∃ c ∈ S, a ∈ c :=
suffices ∀ C, a ∈ C → ∀ (l : list (computation α)) S,
  corec parallel.aux1 (l, S) = C → ∃ c, (c ∈ l ∨ c ∈ S) ∧ a ∈ c,
from let ⟨c, h1, h2⟩ := this _ h [] S rfl in ⟨c, h1.resolve_left id, h2⟩,
begin
  let F : list (computation α) → α ⊕ list (computation α) → Prop,
  { intros l a, cases a with a l',
    exact ∃ c ∈ l, a ∈ c,
    exact ∀ a', (∃ c ∈ l', a' ∈ c) → (∃ c ∈ l, a' ∈ c) },
  have lem1 : ∀ (l : list (computation α)), F l (parallel.aux2 l),
  { intro l, induction l with c l IH; simp [parallel.aux2],
    { intros a h, rcases h with ⟨c, hn, _⟩,
      exact false.elim hn },
    { simp [parallel.aux2] at IH,
      cases list.foldr parallel.aux2._match_1 (sum.inr list.nil) l with a ls;
      simp [parallel.aux2],
      { rcases IH with ⟨c', cl, ac⟩,
        refine ⟨c', or.inr cl, ac⟩ },
      { induction h : destruct c with a c'; simp [rmap],
        { refine ⟨c, list.mem_cons_self _ _, _⟩,
          rw destruct_eq_ret h,
          apply ret_mem },
        { intros a' h, rcases h with ⟨d, dm, ad⟩,
          simp at dm, cases dm with e dl,
          { rw e at ad, refine ⟨c, list.mem_cons_self _ _, _⟩,
            rw destruct_eq_think h,
            exact think_mem ad },
          { cases IH a' ⟨d, dl, ad⟩ with d dm, cases dm with dm ad,
            exact ⟨d, or.inr dm, ad⟩ } } } } },
  intros C aC, refine mem_rec_on aC _ (λ C' IH, _);
  intros l S e; have e' := congr_arg destruct e; have := lem1 l;
  simp [parallel.aux1] at e'; cases parallel.aux2 l with a' l'; injection e' with h',
  { rw h' at this, rcases this with ⟨c, cl, ac⟩,
    exact ⟨c, or.inl cl, ac⟩ },
  { induction e : seq.destruct S with a; rw e at h',
    { exact let ⟨d, o, ad⟩ := IH _ _ h',
        ⟨c, cl, ac⟩ := this a ⟨d, o.resolve_right (not_mem_nil _), ad⟩ in
      ⟨c, or.inl cl, ac⟩ },
    { cases a with o S', cases o with c; simp [parallel.aux1] at h';
      rcases IH _ _ h' with ⟨d, dl | dS', ad⟩,
      { exact let ⟨c, cl, ac⟩ := this a ⟨d, dl, ad⟩ in ⟨c, or.inl cl, ac⟩ },
      { refine ⟨d, or.inr _, ad⟩,
        rw seq.destruct_eq_cons e,
        exact seq.mem_cons_of_mem _ dS' },
      { simp at dl, cases dl with dc dl,
        { rw dc at ad, refine ⟨c, or.inr _, ad⟩,
          rw seq.destruct_eq_cons e,
          apply seq.mem_cons },
        { exact let ⟨c, cl, ac⟩ := this a ⟨d, dl, ad⟩ in ⟨c, or.inl cl, ac⟩ } },
      { refine ⟨d, or.inr _, ad⟩,
        rw seq.destruct_eq_cons e,
        exact seq.mem_cons_of_mem _ dS' } } }
end

theorem map_parallel (f : α → β) (S) : map f (parallel S) = parallel (S.map (map f)) :=
begin
  refine eq_of_bisim (λ c1 c2, ∃ l S,
    c1 = map f (corec parallel.aux1 (l, S)) ∧
    c2 = corec parallel.aux1 (l.map (map f), S.map (map f))) _ ⟨[], S, rfl, rfl⟩,
  intros c1 c2 h, exact match c1, c2, h with ._, ._, ⟨l, S, rfl, rfl⟩ := begin
    clear _match,
    have : parallel.aux2 (l.map (map f)) = lmap f (rmap (list.map (map f)) (parallel.aux2 l)),
    { simp [parallel.aux2],
      induction l with c l IH; simp, rw [IH],
      cases list.foldr parallel.aux2._match_1 (sum.inr list.nil) l; simp [parallel.aux2],
      cases destruct c; simp },
    simp [parallel.aux1], rw this, cases parallel.aux2 l with a l'; simp,
    apply S.cases_on _ (λ c S, _) (λ S, _); simp; simp [parallel.aux1];
    exact ⟨_, _, rfl, rfl⟩
  end end
end

theorem parallel_empty (S : wseq (computation α)) (h : S.head ~> none) :
parallel S = empty _ :=
eq_empty_of_not_terminates $ λ ⟨⟨a, m⟩⟩,
let ⟨c, cs, ac⟩ := exists_of_mem_parallel m,
    ⟨n, nm⟩ := exists_nth_of_mem cs,
    ⟨c', h'⟩ := head_some_of_nth_some nm in by injection h h'

-- The reason this isn't trivial from exists_of_mem_parallel is because it eliminates to Sort
def parallel_rec {S : wseq (computation α)} (C : α → Sort v)
  (H : ∀ s ∈ S, ∀ a ∈ s, C a) {a} (h : a ∈ parallel S) : C a :=
begin
  let T : wseq (computation (α × computation α)) :=
    S.map (λc, c.map (λ a, (a, c))),
  have : S = T.map (map (λ c, c.1)),
  { rw [←wseq.map_comp], refine (wseq.map_id _).symm.trans (congr_arg (λ f, wseq.map f S) _),
    funext c, dsimp [id, function.comp], rw [←map_comp], exact (map_id _).symm },
  have pe := congr_arg parallel this, rw ←map_parallel at pe,
  have h' := h, rw pe at h',
  haveI : terminates (parallel T) := (terminates_map_iff _ _).1 ⟨⟨_, h'⟩⟩,
  induction e : get (parallel T) with a' c,
  have : a ∈ c ∧ c ∈ S,
  { rcases exists_of_mem_map h' with ⟨d, dT, cd⟩,
    rw get_eq_of_mem _ dT at e, cases e, dsimp at cd, cases cd,
    rcases exists_of_mem_parallel dT with ⟨d', dT', ad'⟩,
    rcases wseq.exists_of_mem_map dT' with ⟨c', cs', e'⟩,
    rw ←e' at ad',
    rcases exists_of_mem_map ad' with ⟨a', ac', e'⟩, injection e' with i1 i2,
    constructor, rwa [i1, i2] at ac', rwa i2 at cs' },
  cases this with ac cs, apply H _ cs _ ac
end

theorem parallel_promises {S : wseq (computation α)} {a}
  (H : ∀ s ∈ S, s ~> a) : parallel S ~> a :=
λ a' ma', let ⟨c, cs, ac⟩ := exists_of_mem_parallel ma' in H _ cs ac

theorem mem_parallel {S : wseq (computation α)} {a}
  (H : ∀ s ∈ S, s ~> a) {c} (cs : c ∈ S) (ac : a ∈ c) : a ∈ parallel S :=
by haveI := terminates_of_mem ac; haveI := terminates_parallel cs;
   exact mem_of_promises _ (parallel_promises H)

theorem parallel_congr_lem {S T : wseq (computation α)} {a}
  (H : S.lift_rel equiv T) : (∀ s ∈ S, s ~> a) ↔ (∀ t ∈ T, t ~> a) :=
⟨λ h1 t tT, let ⟨s, sS, se⟩ := wseq.exists_of_lift_rel_right H tT in
  (promises_congr se _).1 (h1 _ sS),
λ h2 s sS, let ⟨t, tT, se⟩ := wseq.exists_of_lift_rel_left H sS in
  (promises_congr se _).2 (h2 _ tT)⟩

-- The parallel operation is only deterministic when all computation paths lead to the same value
theorem parallel_congr_left {S T : wseq (computation α)} {a}
  (h1 : ∀ s ∈ S, s ~> a) (H : S.lift_rel equiv T) : parallel S ~ parallel T :=
let h2 := (parallel_congr_lem H).1 h1 in
λ a', ⟨λh, by have aa := parallel_promises h1 h; rw ←aa; rw ←aa at h; exact
  let ⟨s, sS, as⟩ := exists_of_mem_parallel h,
      ⟨t, tT, st⟩ := wseq.exists_of_lift_rel_left H sS,
      aT := (st _).1 as in mem_parallel h2 tT aT,
λh, by have aa := parallel_promises h2 h; rw ←aa; rw ←aa at h; exact
  let ⟨s, sS, as⟩ := exists_of_mem_parallel h,
      ⟨t, tT, st⟩ := wseq.exists_of_lift_rel_right H sS,
      aT := (st _).2 as in mem_parallel h1 tT aT⟩

theorem parallel_congr_right {S T : wseq (computation α)} {a}
  (h2 : ∀ t ∈ T, t ~> a) (H : S.lift_rel equiv T) : parallel S ~ parallel T :=
parallel_congr_left ((parallel_congr_lem H).2 h2) H

end computation


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

! This file was ported from Lean 3 source module control.monad.basic
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Logic.Equiv.Defs
import Mathbin.Tactic.Basic

/-!
# Monad

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

## Attributes

 * ext
 * functor_norm
 * monad_norm

## Implementation Details

Set of rewrite rules and automation for monads in general and
`reader_t`, `state_t`, `except_t` and `option_t` in particular.

The rewrite rules for monads are carefully chosen so that `simp with
functor_norm` will not introduce monadic vocabulary in a context where
applicatives would do just fine but will handle monadic notation
already present in an expression.

In a context where monadic reasoning is desired `simp with monad_norm`
will translate functor and applicative notation into monad notation
and use regular `functor_norm` rules as well.

## Tags

functor, applicative, monad, simp

-/

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:61:9: unsupported: weird string -/
/- failed to parenthesize: unknown constant 'Lean.Meta._root_.Lean.Parser.Command.registerSimpAttr'
[PrettyPrinter.parenthesize.input] (Lean.Meta._root_.Lean.Parser.Command.registerSimpAttr
     [(Command.docComment
       "/--"
       "./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:61:9: unsupported: weird string -/")]
     "register_simp_attr"
     `monad_norm)-/-- failed to format: unknown constant 'Lean.Meta._root_.Lean.Parser.Command.registerSimpAttr'
/-- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:61:9: unsupported: weird string -/
  register_simp_attr
  monad_norm

/- [mathport] port note: move this to another file, it won't work here -/
attribute [monad_norm] functor_norm

attribute [ext] ReaderT.ext StateT.ext ExceptT.ext OptionT.ext

attribute [functor_norm] bind_assoc pure_bind bind_pure

attribute [monad_norm] seq_eq_bind_map

universe u v

/- warning: map_eq_bind_pure_comp -> map_eq_bind_pure_comp is a dubious translation:
lean 3 declaration is
  forall (m : Type.{u1} -> Type.{u2}) [_inst_1 : Monad.{u1, u2} m] [_inst_2 : LawfulMonad.{u1, u2} m _inst_1] {α : Type.{u1}} {β : Type.{u1}} (f : α -> β) (x : m α), Eq.{succ u2} (m β) (Functor.map.{u1, u2} (fun {α : Type.{u1}} => m α) (Applicative.toFunctor.{u1, u2} (fun {α : Type.{u1}} => m α) (Monad.toApplicative.{u1, u2} (fun {α : Type.{u1}} => m α) _inst_1)) α β f x) (Bind.bind.{u1, u2} m (Monad.toHasBind.{u1, u2} m _inst_1) α β x (Function.comp.{succ u1, succ u1, succ u2} α β (m β) (Pure.pure.{u1, u2} m (Applicative.toHasPure.{u1, u2} m (Monad.toApplicative.{u1, u2} m _inst_1)) β) f))
but is expected to have type
  forall {m : Type.{u1}} {_inst_1 : Type.{u1}} (_inst_2 : Type.{u1} -> Type.{u2}) [α : Monad.{u1, u2} _inst_2] [β : LawfulMonad.{u1, u2} _inst_2 α] (f : m -> _inst_1) (x : _inst_2 m), Eq.{succ u2} (_inst_2 _inst_1) (Functor.map.{u1, u2} _inst_2 (Applicative.toFunctor.{u1, u2} _inst_2 (Monad.toApplicative.{u1, u2} _inst_2 α)) m _inst_1 f x) (Bind.bind.{u1, u2} _inst_2 (Monad.toBind.{u1, u2} _inst_2 α) m _inst_1 x (Function.comp.{succ u1, succ u1, succ u2} m _inst_1 (_inst_2 _inst_1) (Pure.pure.{u1, u2} _inst_2 (Applicative.toPure.{u1, u2} _inst_2 (Monad.toApplicative.{u1, u2} _inst_2 α)) _inst_1) f))
Case conversion may be inaccurate. Consider using '#align map_eq_bind_pure_comp map_eq_bind_pure_compₓ'. -/
@[monad_norm]
theorem map_eq_bind_pure_comp (m : Type u → Type v) [Monad m] [LawfulMonad m] {α β : Type u}
    (f : α → β) (x : m α) : f <$> x = x >>= pure ∘ f := by rw [bind_pure_comp_eq_map]
#align map_eq_bind_pure_comp map_eq_bind_pure_comp

/- warning: state_t.eval -> StateT.eval is a dubious translation:
lean 3 declaration is
  forall {m : Type.{u1} -> Type.{u2}} [_inst_1 : Functor.{u1, u2} m] {σ : Type.{u1}} {α : Type.{u1}}, (StateTₓ.{u1, u2} σ m α) -> σ -> (m α)
but is expected to have type
  forall {m : Type.{u1}} {_inst_1 : Type.{u1}} {σ : Type.{u1} -> Type.{u2}} [α : Functor.{u1, u2} σ], (StateT.{u1, u2} m σ _inst_1) -> m -> (σ _inst_1)
Case conversion may be inaccurate. Consider using '#align state_t.eval StateT.evalₓ'. -/
/-- run a `state_t` program and discard the final state -/
def StateT.eval {m : Type u → Type v} [Functor m] {σ α} (cmd : StateT σ m α) (s : σ) : m α :=
  Prod.fst <$> cmd.run s
#align state_t.eval StateT.eval

universe u₀ u₁ v₀ v₁

/- warning: state_t.equiv -> StateT.equiv is a dubious translation:
lean 3 declaration is
  forall {m₁ : Type.{u1} -> Type.{u3}} {m₂ : Type.{u2} -> Type.{u4}} {α₁ : Type.{u1}} {σ₁ : Type.{u1}} {α₂ : Type.{u2}} {σ₂ : Type.{u2}}, (Equiv.{max (succ u1) (succ u3), max (succ u2) (succ u4)} (σ₁ -> (m₁ (Prod.{u1, u1} α₁ σ₁))) (σ₂ -> (m₂ (Prod.{u2, u2} α₂ σ₂)))) -> (Equiv.{succ (max u1 u3), succ (max u2 u4)} (StateTₓ.{u1, u3} σ₁ m₁ α₁) (StateTₓ.{u2, u4} σ₂ m₂ α₂))
but is expected to have type
  forall {m₁ : Type.{u1}} {m₂ : Type.{u1}} {α₁ : Type.{u3}} {σ₁ : Type.{u3}} {α₂ : Type.{u1} -> Type.{u2}} {σ₂ : Type.{u3} -> Type.{u4}}, (Equiv.{max (succ u2) (succ u1), max (succ u4) (succ u3)} (m₁ -> (α₂ (Prod.{u1, u1} m₂ m₁))) (α₁ -> (σ₂ (Prod.{u3, u3} σ₁ α₁)))) -> (Equiv.{max (succ u2) (succ u1), max (succ u4) (succ u3)} (StateT.{u1, u2} m₁ α₂ m₂) (StateT.{u3, u4} α₁ σ₂ σ₁))
Case conversion may be inaccurate. Consider using '#align state_t.equiv StateT.equivₓ'. -/
/-- reduce the equivalence between two state monads to the equivalence between
their respective function spaces -/
def StateT.equiv {m₁ : Type u₀ → Type v₀} {m₂ : Type u₁ → Type v₁} {α₁ σ₁ : Type u₀}
    {α₂ σ₂ : Type u₁} (F : (σ₁ → m₁ (α₁ × σ₁)) ≃ (σ₂ → m₂ (α₂ × σ₂))) :
    StateT σ₁ m₁ α₁ ≃ StateT σ₂ m₂ α₂
    where
  toFun := fun ⟨f⟩ => ⟨F f⟩
  invFun := fun ⟨f⟩ => ⟨F.symm f⟩
  left_inv := fun ⟨f⟩ => congr_arg StateT.mk <| F.left_inv _
  right_inv := fun ⟨f⟩ => congr_arg StateT.mk <| F.right_inv _
#align state_t.equiv StateT.equiv

/- warning: reader_t.equiv -> ReaderT.equiv is a dubious translation:
lean 3 declaration is
  forall {m₁ : Type.{u1} -> Type.{u3}} {m₂ : Type.{u2} -> Type.{u4}} {α₁ : Type.{u1}} {ρ₁ : Type.{u1}} {α₂ : Type.{u2}} {ρ₂ : Type.{u2}}, (Equiv.{max (succ u1) (succ u3), max (succ u2) (succ u4)} (ρ₁ -> (m₁ α₁)) (ρ₂ -> (m₂ α₂))) -> (Equiv.{succ (max u1 u3), succ (max u2 u4)} (ReaderTₓ.{u1, u3} ρ₁ m₁ α₁) (ReaderTₓ.{u2, u4} ρ₂ m₂ α₂))
but is expected to have type
  forall {m₁ : Type.{u1}} {m₂ : Type.{u1}} {α₁ : Type.{u3}} {ρ₁ : Type.{u3}} {α₂ : Type.{u1} -> Type.{u2}} {ρ₂ : Type.{u3} -> Type.{u4}}, (Equiv.{max (succ u2) (succ u1), max (succ u4) (succ u3)} (m₁ -> (α₂ m₂)) (α₁ -> (ρ₂ ρ₁))) -> (Equiv.{max (succ u2) (succ u1), max (succ u4) (succ u3)} (ReaderT.{u1, u2} m₁ α₂ m₂) (ReaderT.{u3, u4} α₁ ρ₂ ρ₁))
Case conversion may be inaccurate. Consider using '#align reader_t.equiv ReaderT.equivₓ'. -/
/-- reduce the equivalence between two reader monads to the equivalence between
their respective function spaces -/
def ReaderT.equiv {m₁ : Type u₀ → Type v₀} {m₂ : Type u₁ → Type v₁} {α₁ ρ₁ : Type u₀}
    {α₂ ρ₂ : Type u₁} (F : (ρ₁ → m₁ α₁) ≃ (ρ₂ → m₂ α₂)) : ReaderT ρ₁ m₁ α₁ ≃ ReaderT ρ₂ m₂ α₂
    where
  toFun := fun ⟨f⟩ => ⟨F f⟩
  invFun := fun ⟨f⟩ => ⟨F.symm f⟩
  left_inv := fun ⟨f⟩ => congr_arg ReaderT.mk <| F.left_inv _
  right_inv := fun ⟨f⟩ => congr_arg ReaderT.mk <| F.right_inv _
#align reader_t.equiv ReaderT.equiv


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

! This file was ported from Lean 3 source module control.applicative
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Group.Defs
import Mathbin.Control.Functor

/-!
# `applicative` instances

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

This file provides `applicative` instances for concrete functors:
* `id`
* `functor.comp`
* `functor.const`
* `functor.add_const`
-/

universe u v w

section Lemmas

open Function

variable {F : Type u → Type v}

variable [Applicative F] [LawfulApplicative F]

variable {α β γ σ : Type u}

/- warning: applicative.map_seq_map -> Applicative.map_seq_map is a dubious translation:
lean 3 declaration is
  forall {F : Type.{u1} -> Type.{u2}} [_inst_1 : Applicative.{u1, u2} F] [_inst_2 : LawfulApplicative.{u1, u2} F _inst_1] {α : Type.{u1}} {β : Type.{u1}} {γ : Type.{u1}} {σ : Type.{u1}} (f : α -> β -> γ) (g : σ -> β) (x : F α) (y : F σ), Eq.{succ u2} (F γ) (Seq.seq.{u1, u2} (fun {α : Type.{u1}} => F α) (Applicative.toHasSeq.{u1, u2} (fun {α : Type.{u1}} => F α) _inst_1) β γ (Functor.map.{u1, u2} (fun {α : Type.{u1}} => F α) (Applicative.toFunctor.{u1, u2} (fun {α : Type.{u1}} => F α) _inst_1) α (β -> γ) f x) (Functor.map.{u1, u2} F (Applicative.toFunctor.{u1, u2} F _inst_1) σ β g y)) (Seq.seq.{u1, u2} F (Applicative.toHasSeq.{u1, u2} F _inst_1) σ γ (Functor.map.{u1, u2} F (Applicative.toFunctor.{u1, u2} F _inst_1) α (σ -> γ) (Function.comp.{succ u1, succ u1, succ u1} α (β -> γ) (σ -> γ) (flip.{succ u1, succ u1, succ u1} (β -> γ) (σ -> β) (σ -> γ) (Function.comp.{succ u1, succ u1, succ u1} σ β γ) g) f) x) y)
but is expected to have type
  forall {F : Type.{u1} -> Type.{u2}} [_inst_1 : Applicative.{u1, u2} F] [_inst_2 : LawfulApplicative.{u1, u2} F _inst_1] {α : Type.{u1}} {β : Type.{u1}} {γ : Type.{u1}} {σ : Type.{u1}} (f : α -> β -> γ) (g : σ -> β) (x : F α) (y : F σ), Eq.{succ u2} (F γ) (Seq.seq.{u1, u2} F (Applicative.toSeq.{u1, u2} F _inst_1) β γ (Functor.map.{u1, u2} F (Applicative.toFunctor.{u1, u2} F _inst_1) α (β -> γ) f x) (fun (x._@.Mathlib.Control.Applicative._hyg.84 : Unit) => Functor.map.{u1, u2} F (Applicative.toFunctor.{u1, u2} F _inst_1) σ β g y)) (Seq.seq.{u1, u2} F (Applicative.toSeq.{u1, u2} F _inst_1) σ γ (Functor.map.{u1, u2} F (Applicative.toFunctor.{u1, u2} F _inst_1) α (σ -> γ) (Function.comp.{succ u1, succ u1, succ u1} α (β -> γ) (σ -> γ) (flip.{succ u1, succ u1, succ u1} (β -> γ) (σ -> β) (σ -> γ) (fun (x._@.Mathlib.Control.Applicative._hyg.105 : β -> γ) (x._@.Mathlib.Control.Applicative._hyg.107 : σ -> β) => Function.comp.{succ u1, succ u1, succ u1} σ β γ x._@.Mathlib.Control.Applicative._hyg.105 x._@.Mathlib.Control.Applicative._hyg.107) g) f) x) (fun (x._@.Mathlib.Control.Applicative._hyg.124 : Unit) => y))
Case conversion may be inaccurate. Consider using '#align applicative.map_seq_map Applicative.map_seq_mapₓ'. -/
theorem Applicative.map_seq_map (f : α → β → γ) (g : σ → β) (x : F α) (y : F σ) :
    f <$> x <*> g <$> y = (flip (· ∘ ·) g ∘ f) <$> x <*> y := by simp [flip, functor_norm]
#align applicative.map_seq_map Applicative.map_seq_map

/- warning: applicative.pure_seq_eq_map' -> Applicative.pure_seq_eq_map' is a dubious translation:
lean 3 declaration is
  forall {F : Type.{u1} -> Type.{u2}} [_inst_1 : Applicative.{u1, u2} F] [_inst_2 : LawfulApplicative.{u1, u2} F _inst_1] {α : Type.{u1}} {β : Type.{u1}} (f : α -> β), Eq.{succ u2} ((F α) -> (F β)) (Seq.seq.{u1, u2} F (Applicative.toHasSeq.{u1, u2} F _inst_1) α β (Pure.pure.{u1, u2} F (Applicative.toHasPure.{u1, u2} F _inst_1) (α -> β) f)) (Functor.map.{u1, u2} F (Applicative.toFunctor.{u1, u2} F _inst_1) α β f)
but is expected to have type
  forall {F : Type.{u1} -> Type.{u2}} [_inst_1 : Applicative.{u1, u2} F] [_inst_2 : LawfulApplicative.{u1, u2} F _inst_1] {α : Type.{u1}} {β : Type.{u1}} (f : α -> β), Eq.{succ u2} ((F α) -> (F β)) ((fun (x._@.Mathlib.Control.Applicative._hyg.160 : F (α -> β)) (x._@.Mathlib.Control.Applicative._hyg.162 : F α) => Seq.seq.{u1, u2} F (Applicative.toSeq.{u1, u2} F _inst_1) α β x._@.Mathlib.Control.Applicative._hyg.160 (fun (x._@.Mathlib.Control.Applicative._hyg.175 : Unit) => x._@.Mathlib.Control.Applicative._hyg.162)) (Pure.pure.{u1, u2} F (Applicative.toPure.{u1, u2} F _inst_1) (α -> β) f)) ((fun (x._@.Mathlib.Control.Applicative._hyg.192 : α -> β) (x._@.Mathlib.Control.Applicative._hyg.194 : F α) => Functor.map.{u1, u2} F (Applicative.toFunctor.{u1, u2} F _inst_1) α β x._@.Mathlib.Control.Applicative._hyg.192 x._@.Mathlib.Control.Applicative._hyg.194) f)
Case conversion may be inaccurate. Consider using '#align applicative.pure_seq_eq_map' Applicative.pure_seq_eq_map'ₓ'. -/
theorem Applicative.pure_seq_eq_map' (f : α → β) : (· <*> ·) (pure f : F (α → β)) = (· <$> ·) f :=
  by ext <;> simp [functor_norm]
#align applicative.pure_seq_eq_map' Applicative.pure_seq_eq_map'

/- warning: applicative.ext -> Applicative.ext is a dubious translation:
lean 3 declaration is
  forall {F : Type.{u1} -> Type.{u2}} {A1 : Applicative.{u1, u2} F} {A2 : Applicative.{u1, u2} F} [_inst_3 : LawfulApplicative.{u1, u2} F A1] [_inst_4 : LawfulApplicative.{u1, u2} F A2], (forall {α : Type.{u1}} (x : α), Eq.{succ u2} (F α) (Pure.pure.{u1, u2} F (Applicative.toHasPure.{u1, u2} F A1) α x) (Pure.pure.{u1, u2} F (Applicative.toHasPure.{u1, u2} F A2) α x)) -> (forall {α : Type.{u1}} {β : Type.{u1}} (f : F (α -> β)) (x : F α), Eq.{succ u2} (F β) (Seq.seq.{u1, u2} F (Applicative.toHasSeq.{u1, u2} F A1) α β f x) (Seq.seq.{u1, u2} F (Applicative.toHasSeq.{u1, u2} F A2) α β f x)) -> (Eq.{max (succ (succ u1)) (succ u2)} (Applicative.{u1, u2} F) A1 A2)
but is expected to have type
  forall {F : Type.{u2} -> Type.{u1}} {A1 : Applicative.{u2, u1} F} {A2 : Applicative.{u2, u1} F} [_inst_3 : LawfulApplicative.{u2, u1} F A1] [_inst_4 : LawfulApplicative.{u2, u1} F A2], (forall {α : Type.{u2}} (x : α), Eq.{succ u1} (F α) (Pure.pure.{u2, u1} F (Applicative.toPure.{u2, u1} F A1) α x) (Pure.pure.{u2, u1} F (Applicative.toPure.{u2, u1} F A2) α x)) -> (forall {α : Type.{u2}} {β : Type.{u2}} (f : F (α -> β)) (x : F α), Eq.{succ u1} (F β) (Seq.seq.{u2, u1} F (Applicative.toSeq.{u2, u1} F A1) α β f (fun (x._@.Mathlib.Control.Applicative._hyg.293 : Unit) => x)) (Seq.seq.{u2, u1} F (Applicative.toSeq.{u2, u1} F A2) α β f (fun (x._@.Mathlib.Control.Applicative._hyg.306 : Unit) => x))) -> (Eq.{max (succ (succ u2)) (succ u1)} (Applicative.{u2, u1} F) A1 A2)
Case conversion may be inaccurate. Consider using '#align applicative.ext Applicative.extₓ'. -/
theorem Applicative.ext {F} :
    ∀ {A1 : Applicative F} {A2 : Applicative F} [@LawfulApplicative F A1] [@LawfulApplicative F A2]
      (H1 : ∀ {α : Type u} (x : α), @Pure.pure _ A1.toHasPure _ x = @Pure.pure _ A2.toHasPure _ x)
      (H2 :
        ∀ {α β : Type u} (f : F (α → β)) (x : F α),
          @Seq.seq _ A1.toHasSeq _ _ f x = @Seq.seq _ A2.toHasSeq _ _ f x),
      A1 = A2
  | { toFunctor := F1
      seq := s1
      pure := p1
      seqLeft := sl1
      seqRight := sr1 },
    { toFunctor := F2
      seq := s2
      pure := p2
      seqLeft := sl2
      seqRight := sr2 }, L1, L2, H1, H2 =>
    by
    obtain rfl : @p1 = @p2 := by
      funext α x
      apply H1
    obtain rfl : @s1 = @s2 := by
      funext α β f x
      apply H2
    cases L1
    cases L2
    obtain rfl : F1 = F2 := by
      skip
      apply Functor.ext
      intros
      exact (L1_pure_seq_eq_map _ _).symm.trans (L2_pure_seq_eq_map _ _)
    congr <;> funext α β x y
    · exact (L1_seq_left_eq _ _).trans (L2_seq_left_eq _ _).symm
    · exact (L1_seq_right_eq _ _).trans (L2_seq_right_eq _ _).symm
#align applicative.ext Applicative.ext

end Lemmas

instance : CommApplicative id := by refine' { .. } <;> intros <;> rfl

namespace Functor

namespace Comp

open Function hiding comp

open Functor

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

variable [Applicative F] [Applicative G]

variable [LawfulApplicative F] [LawfulApplicative G]

variable {α β γ : Type v}

#print Functor.Comp.map_pure /-
theorem map_pure (f : α → β) (x : α) : (f <$> pure x : Comp F G β) = pure (f x) :=
  Comp.ext <| by simp
#align functor.comp.map_pure Functor.Comp.map_pure
-/

/- warning: functor.comp.seq_pure -> Functor.Comp.seq_pure is a dubious translation:
lean 3 declaration is
  forall {F : Type.{u1} -> Type.{u3}} {G : Type.{u2} -> Type.{u1}} [_inst_1 : Applicative.{u1, u3} F] [_inst_2 : Applicative.{u2, u1} G] [_inst_3 : LawfulApplicative.{u1, u3} F _inst_1] [_inst_4 : LawfulApplicative.{u2, u1} G _inst_2] {α : Type.{u2}} {β : Type.{u2}} (f : Functor.Comp.{u1, u2, u3} F G (α -> β)) (x : α), Eq.{succ u3} (Functor.Comp.{u1, u2, u3} F G β) (Seq.seq.{u2, u3} (Functor.Comp.{u1, u2, u3} F G) (Functor.Comp.hasSeq.{u1, u2, u3} F G _inst_1 _inst_2) α β f (Pure.pure.{u2, u3} (Functor.Comp.{u1, u2, u3} F G) (Functor.Comp.hasPure.{u1, u2, u3} F G _inst_1 _inst_2) α x)) (Functor.map.{u2, u3} (Functor.Comp.{u1, u2, u3} F G) (Functor.Comp.functor.{u1, u2, u3} F G (Applicative.toFunctor.{u1, u3} F _inst_1) (Applicative.toFunctor.{u2, u1} G _inst_2)) (α -> β) β (fun (g : α -> β) => g x) f)
but is expected to have type
  forall {F : Type.{u1} -> Type.{u3}} {G : Type.{u2} -> Type.{u1}} [_inst_1 : Applicative.{u1, u3} F] [_inst_2 : Applicative.{u2, u1} G] [_inst_3 : LawfulApplicative.{u1, u3} F _inst_1] [_inst_4 : LawfulApplicative.{u2, u1} G _inst_2] {α : Type.{u2}} {β : Type.{u2}} (f : Functor.Comp.{u1, u2, u3} F G (α -> β)) (x : α), Eq.{succ u3} (Functor.Comp.{u1, u2, u3} F G β) (Seq.seq.{u2, u3} (Functor.Comp.{u1, u2, u3} F G) (Functor.Comp.instSeqComp.{u1, u2, u3} F G _inst_1 _inst_2) α β f (fun (x._@.Mathlib.Control.Applicative._hyg.1000 : Unit) => Pure.pure.{u2, u3} (Functor.Comp.{u1, u2, u3} F G) (Functor.Comp.instPureComp.{u1, u2, u3} F G _inst_1 _inst_2) α x)) (Functor.map.{u2, u3} (Functor.Comp.{u1, u2, u3} F G) (Functor.Comp.functor.{u1, u2, u3} F G (Applicative.toFunctor.{u1, u3} F _inst_1) (Applicative.toFunctor.{u2, u1} G _inst_2)) (α -> β) β (fun (g : α -> β) => g x) f)
Case conversion may be inaccurate. Consider using '#align functor.comp.seq_pure Functor.Comp.seq_pureₓ'. -/
theorem seq_pure (f : Comp F G (α → β)) (x : α) : f <*> pure x = (fun g : α → β => g x) <$> f :=
  Comp.ext <| by simp [(· ∘ ·), functor_norm]
#align functor.comp.seq_pure Functor.Comp.seq_pure

/- warning: functor.comp.seq_assoc -> Functor.Comp.seq_assoc is a dubious translation:
lean 3 declaration is
  forall {F : Type.{u1} -> Type.{u3}} {G : Type.{u2} -> Type.{u1}} [_inst_1 : Applicative.{u1, u3} F] [_inst_2 : Applicative.{u2, u1} G] [_inst_3 : LawfulApplicative.{u1, u3} F _inst_1] [_inst_4 : LawfulApplicative.{u2, u1} G _inst_2] {α : Type.{u2}} {β : Type.{u2}} {γ : Type.{u2}} (x : Functor.Comp.{u1, u2, u3} F G α) (f : Functor.Comp.{u1, u2, u3} F G (α -> β)) (g : Functor.Comp.{u1, u2, u3} F G (β -> γ)), Eq.{succ u3} (Functor.Comp.{u1, u2, u3} F G γ) (Seq.seq.{u2, u3} (Functor.Comp.{u1, u2, u3} F G) (Functor.Comp.hasSeq.{u1, u2, u3} F G _inst_1 _inst_2) β γ g (Seq.seq.{u2, u3} (Functor.Comp.{u1, u2, u3} F G) (Functor.Comp.hasSeq.{u1, u2, u3} F G _inst_1 _inst_2) α β f x)) (Seq.seq.{u2, u3} (Functor.Comp.{u1, u2, u3} F G) (Functor.Comp.hasSeq.{u1, u2, u3} F G _inst_1 _inst_2) α γ (Seq.seq.{u2, u3} (Functor.Comp.{u1, u2, u3} F G) (Functor.Comp.hasSeq.{u1, u2, u3} F G _inst_1 _inst_2) (α -> β) (α -> γ) (Functor.map.{u2, u3} (Functor.Comp.{u1, u2, u3} F G) (Functor.Comp.functor.{u1, u2, u3} F G (Applicative.toFunctor.{u1, u3} F _inst_1) (Applicative.toFunctor.{u2, u1} G _inst_2)) (β -> γ) ((α -> β) -> α -> γ) (Function.comp.{succ u2, succ u2, succ u2} α β γ) g) f) x)
but is expected to have type
  forall {F : Type.{u1} -> Type.{u3}} {G : Type.{u2} -> Type.{u1}} [_inst_1 : Applicative.{u1, u3} F] [_inst_2 : Applicative.{u2, u1} G] [_inst_3 : LawfulApplicative.{u1, u3} F _inst_1] [_inst_4 : LawfulApplicative.{u2, u1} G _inst_2] {α : Type.{u2}} {β : Type.{u2}} {γ : Type.{u2}} (x : Functor.Comp.{u1, u2, u3} F G α) (f : Functor.Comp.{u1, u2, u3} F G (α -> β)) (g : Functor.Comp.{u1, u2, u3} F G (β -> γ)), Eq.{succ u3} (Functor.Comp.{u1, u2, u3} F G γ) (Seq.seq.{u2, u3} (Functor.Comp.{u1, u2, u3} F G) (Functor.Comp.instSeqComp.{u1, u2, u3} F G _inst_1 _inst_2) β γ g (fun (x._@.Mathlib.Control.Applicative._hyg.1084 : Unit) => Seq.seq.{u2, u3} (Functor.Comp.{u1, u2, u3} F G) (Functor.Comp.instSeqComp.{u1, u2, u3} F G _inst_1 _inst_2) α β f (fun (x._@.Mathlib.Control.Applicative._hyg.1096 : Unit) => x))) (Seq.seq.{u2, u3} (Functor.Comp.{u1, u2, u3} F G) (Functor.Comp.instSeqComp.{u1, u2, u3} F G _inst_1 _inst_2) α γ (Seq.seq.{u2, u3} (Functor.Comp.{u1, u2, u3} F G) (Functor.Comp.instSeqComp.{u1, u2, u3} F G _inst_1 _inst_2) (α -> β) (α -> γ) (Functor.map.{u2, u3} (Functor.Comp.{u1, u2, u3} F G) (Functor.Comp.functor.{u1, u2, u3} F G (Applicative.toFunctor.{u1, u3} F _inst_1) (Applicative.toFunctor.{u2, u1} G _inst_2)) (β -> γ) ((α -> β) -> α -> γ) (Function.comp.{succ u2, succ u2, succ u2} α β γ) g) (fun (x._@.Mathlib.Control.Applicative._hyg.1116 : Unit) => f)) (fun (x._@.Mathlib.Control.Applicative._hyg.1123 : Unit) => x))
Case conversion may be inaccurate. Consider using '#align functor.comp.seq_assoc Functor.Comp.seq_assocₓ'. -/
theorem seq_assoc (x : Comp F G α) (f : Comp F G (α → β)) (g : Comp F G (β → γ)) :
    g <*> (f <*> x) = @Function.comp α β γ <$> g <*> f <*> x :=
  Comp.ext <| by simp [(· ∘ ·), functor_norm]
#align functor.comp.seq_assoc Functor.Comp.seq_assoc

/- warning: functor.comp.pure_seq_eq_map -> Functor.Comp.pure_seq_eq_map is a dubious translation:
lean 3 declaration is
  forall {F : Type.{u1} -> Type.{u3}} {G : Type.{u2} -> Type.{u1}} [_inst_1 : Applicative.{u1, u3} F] [_inst_2 : Applicative.{u2, u1} G] [_inst_3 : LawfulApplicative.{u1, u3} F _inst_1] [_inst_4 : LawfulApplicative.{u2, u1} G _inst_2] {α : Type.{u2}} {β : Type.{u2}} (f : α -> β) (x : Functor.Comp.{u1, u2, u3} F G α), Eq.{succ u3} (Functor.Comp.{u1, u2, u3} F G β) (Seq.seq.{u2, u3} (fun {α : Type.{u2}} => Functor.Comp.{u1, u2, u3} F G α) (Functor.Comp.hasSeq.{u1, u2, u3} F G _inst_1 _inst_2) α β (Pure.pure.{u2, u3} (fun {α : Type.{u2}} => Functor.Comp.{u1, u2, u3} F G α) (Functor.Comp.hasPure.{u1, u2, u3} F G _inst_1 _inst_2) (α -> β) f) x) (Functor.map.{u2, u3} (Functor.Comp.{u1, u2, u3} F G) (Functor.Comp.functor.{u1, u2, u3} F G (Applicative.toFunctor.{u1, u3} F _inst_1) (Applicative.toFunctor.{u2, u1} G _inst_2)) α β f x)
but is expected to have type
  forall {F : Type.{u1} -> Type.{u3}} {G : Type.{u2} -> Type.{u1}} [_inst_1 : Applicative.{u1, u3} F] [_inst_2 : Applicative.{u2, u1} G] [_inst_3 : LawfulApplicative.{u1, u3} F _inst_1] [_inst_4 : LawfulApplicative.{u2, u1} G _inst_2] {α : Type.{u2}} {β : Type.{u2}} (f : α -> β) (x : Functor.Comp.{u1, u2, u3} F G α), Eq.{succ u3} (Functor.Comp.{u1, u2, u3} F G β) (Seq.seq.{u2, u3} (Functor.Comp.{u1, u2, u3} F G) (Functor.Comp.instSeqComp.{u1, u2, u3} F G _inst_1 _inst_2) α β (Pure.pure.{u2, u3} (Functor.Comp.{u1, u2, u3} F G) (Functor.Comp.instPureComp.{u1, u2, u3} F G _inst_1 _inst_2) (α -> β) f) (fun (x._@.Mathlib.Control.Applicative._hyg.1180 : Unit) => x)) (Functor.map.{u2, u3} (Functor.Comp.{u1, u2, u3} F G) (Functor.Comp.functor.{u1, u2, u3} F G (Applicative.toFunctor.{u1, u3} F _inst_1) (Applicative.toFunctor.{u2, u1} G _inst_2)) α β f x)
Case conversion may be inaccurate. Consider using '#align functor.comp.pure_seq_eq_map Functor.Comp.pure_seq_eq_mapₓ'. -/
theorem pure_seq_eq_map (f : α → β) (x : Comp F G α) : pure f <*> x = f <$> x :=
  Comp.ext <| by simp [Applicative.pure_seq_eq_map', functor_norm]
#align functor.comp.pure_seq_eq_map Functor.Comp.pure_seq_eq_map

instance : LawfulApplicative (Comp F G)
    where
  pure_seq := @Comp.pure_seq_eq_map F G _ _ _ _
  map_pure := @Comp.map_pure F G _ _ _ _
  seq_pure := @Comp.seq_pure F G _ _ _ _
  seq_assoc := @Comp.seq_assoc F G _ _ _ _

/- warning: functor.comp.applicative_id_comp -> Functor.Comp.applicative_id_comp is a dubious translation:
lean 3 declaration is
  forall {F : Type.{u1} -> Type.{u2}} [AF : Applicative.{u1, u2} F] [LF : LawfulApplicative.{u1, u2} F AF], Eq.{max (succ (succ u1)) (succ u2)} (Applicative.{u1, u2} (Functor.Comp.{u2, u1, u2} (id.{succ (succ u2)} Type.{u2}) F)) (Functor.Comp.applicative.{u2, u1, u2} (id.{succ (succ u2)} Type.{u2}) F (Monad.toApplicative.{u2, u2} (id.{succ (succ u2)} Type.{u2}) id.monad.{u2}) AF) AF
but is expected to have type
  forall {F : Type.{u2} -> Type.{u1}} [AF : Applicative.{u2, u1} F] [LF : LawfulApplicative.{u2, u1} F AF], Eq.{max (succ u1) (succ (succ u2))} (Applicative.{u2, u1} (Functor.Comp.{u1, u2, u1} Id.{u1} F)) (Functor.Comp.instApplicativeComp.{u1, u2, u1} Id.{u1} F (Monad.toApplicative.{u1, u1} Id.{u1} Id.instMonadId.{u1}) AF) AF
Case conversion may be inaccurate. Consider using '#align functor.comp.applicative_id_comp Functor.Comp.applicative_id_compₓ'. -/
theorem applicative_id_comp {F} [AF : Applicative F] [LF : LawfulApplicative F] :
    @Comp.applicative id F _ _ = AF :=
  @Applicative.ext F _ _ (@Comp.lawfulApplicative id F _ _ _ _) _ (fun α x => rfl) fun α β f x =>
    rfl
#align functor.comp.applicative_id_comp Functor.Comp.applicative_id_comp

/- warning: functor.comp.applicative_comp_id -> Functor.Comp.applicative_comp_id is a dubious translation:
lean 3 declaration is
  forall {F : Type.{u1} -> Type.{u2}} [AF : Applicative.{u1, u2} F] [LF : LawfulApplicative.{u1, u2} F AF], Eq.{max (succ (succ u1)) (succ u2)} (Applicative.{u1, u2} (Functor.Comp.{u1, u1, u2} F (id.{succ (succ u1)} Type.{u1}))) (Functor.Comp.applicative.{u1, u1, u2} F (id.{succ (succ u1)} Type.{u1}) AF (Monad.toApplicative.{u1, u1} (id.{succ (succ u1)} Type.{u1}) id.monad.{u1})) AF
but is expected to have type
  forall {F : Type.{u2} -> Type.{u1}} [AF : Applicative.{u2, u1} F] [LF : LawfulApplicative.{u2, u1} F AF], Eq.{max (succ u1) (succ (succ u2))} (Applicative.{u2, u1} (Functor.Comp.{u2, u2, u1} F Id.{u2})) (Functor.Comp.instApplicativeComp.{u2, u2, u1} F Id.{u2} AF (Monad.toApplicative.{u2, u2} Id.{u2} Id.instMonadId.{u2})) AF
Case conversion may be inaccurate. Consider using '#align functor.comp.applicative_comp_id Functor.Comp.applicative_comp_idₓ'. -/
theorem applicative_comp_id {F} [AF : Applicative F] [LF : LawfulApplicative F] :
    @Comp.applicative F id _ _ = AF :=
  @Applicative.ext F _ _ (@Comp.lawfulApplicative F id _ _ _ _) _ (fun α x => rfl) fun α β f x =>
    show id <$> f <*> x = f <*> x by rw [id_map]
#align functor.comp.applicative_comp_id Functor.Comp.applicative_comp_id

open CommApplicative

instance {f : Type u → Type w} {g : Type v → Type u} [Applicative f] [Applicative g]
    [CommApplicative f] [CommApplicative g] : CommApplicative (Comp f g) :=
  by
  refine' { @comp.is_lawful_applicative f g _ _ _ _ with .. }
  intros
  casesm*comp _ _ _
  simp! [map, Seq.seq, functor_norm]
  rw [commutative_map]
  simp [comp.mk, flip, (· ∘ ·), functor_norm]
  congr
  funext
  rw [commutative_map]
  congr

end Comp

end Functor

open Functor

/- warning: comp.seq_mk -> Comp.seq_mk is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u3}} {β : Type.{u3}} {f : Type.{u1} -> Type.{u2}} {g : Type.{u3} -> Type.{u1}} [_inst_1 : Applicative.{u1, u2} f] [_inst_2 : Applicative.{u3, u1} g] (h : f (g (α -> β))) (x : f (g α)), Eq.{succ u2} (Functor.Comp.{u1, u3, u2} f g β) (Seq.seq.{u3, u2} (Functor.Comp.{u1, u3, u2} f g) (Functor.Comp.hasSeq.{u1, u3, u2} f g _inst_1 _inst_2) α β (Functor.Comp.mk.{u1, u3, u2} f g (α -> β) h) (Functor.Comp.mk.{u1, u3, u2} f g α x)) (Functor.Comp.mk.{u1, u3, u2} f g β (Seq.seq.{u1, u2} f (Applicative.toHasSeq.{u1, u2} f _inst_1) (g α) (g β) (Functor.map.{u1, u2} f (Applicative.toFunctor.{u1, u2} f _inst_1) (g (α -> β)) ((g α) -> (g β)) (Seq.seq.{u3, u1} g (Applicative.toHasSeq.{u3, u1} g _inst_2) α β) h) x))
but is expected to have type
  forall {α : Type.{u3}} {β : Type.{u3}} {f : Type.{u1} -> Type.{u2}} {g : Type.{u3} -> Type.{u1}} [_inst_1 : Applicative.{u1, u2} f] [_inst_2 : Applicative.{u3, u1} g] (h : f (g (α -> β))) (x : f (g α)), Eq.{succ u2} (Functor.Comp.{u1, u3, u2} f g β) (Seq.seq.{u3, u2} (Functor.Comp.{u1, u3, u2} f g) (Functor.Comp.instSeqComp.{u1, u3, u2} f g _inst_1 _inst_2) α β (Functor.Comp.mk.{u1, u3, u2} f g (α -> β) h) (fun (x._@.Mathlib.Control.Applicative._hyg.1722 : Unit) => Functor.Comp.mk.{u1, u3, u2} f g α x)) (Functor.Comp.mk.{u1, u3, u2} f g β (Seq.seq.{u1, u2} f (Applicative.toSeq.{u1, u2} f _inst_1) (g α) (g β) (Functor.map.{u1, u2} f (Applicative.toFunctor.{u1, u2} f _inst_1) (g (α -> β)) ((g α) -> (g β)) (fun (x._@.Mathlib.Control.Applicative._hyg.1738 : g (α -> β)) (x._@.Mathlib.Control.Applicative._hyg.1740 : g α) => Seq.seq.{u3, u1} g (Applicative.toSeq.{u3, u1} g _inst_2) α β x._@.Mathlib.Control.Applicative._hyg.1738 (fun (x._@.Mathlib.Control.Applicative._hyg.1753 : Unit) => x._@.Mathlib.Control.Applicative._hyg.1740)) h) (fun (x._@.Mathlib.Control.Applicative._hyg.1761 : Unit) => x)))
Case conversion may be inaccurate. Consider using '#align comp.seq_mk Comp.seq_mkₓ'. -/
@[functor_norm]
theorem Comp.seq_mk {α β : Type w} {f : Type u → Type v} {g : Type w → Type u} [Applicative f]
    [Applicative g] (h : f (g (α → β))) (x : f (g α)) :
    Comp.mk h <*> Comp.mk x = Comp.mk (Seq.seq <$> h <*> x) :=
  rfl
#align comp.seq_mk Comp.seq_mk

instance {α} [One α] [Mul α] : Applicative (Const α)
    where
  pure β x := (1 : α)
  seq β γ f x := (f * x : α)

instance {α} [Monoid α] : LawfulApplicative (Const α) := by
  refine' { .. } <;> intros <;> simp [mul_assoc, (· <$> ·), (· <*> ·), pure]

instance {α} [Zero α] [Add α] : Applicative (AddConst α)
    where
  pure β x := (0 : α)
  seq β γ f x := (f + x : α)

instance {α} [AddMonoid α] : LawfulApplicative (AddConst α) := by
  refine' { .. } <;> intros <;> simp [add_assoc, (· <$> ·), (· <*> ·), pure]


import analysis.normed_space.add_torsor_bases
import analysis.convex.caratheodory
import analysis.calculus.cont_diff
import measure_theory.integral.interval_integral
import measure_theory.measure.lebesgue
import topology.algebra.order.floor
import topology.path_connected
import linear_algebra.affine_space.independent

import to_mathlib.smooth_barycentric
import to_mathlib.topology.path
import to_mathlib.measure_theory.parametric_interval_integral
import to_mathlib.equivariant

/-!
# Basic definitions and properties of loops
-/

open set function finite_dimensional int topological_space
open_locale big_operators topology unit_interval
noncomputable theory

variables {K X X' Y Z : Type*}
-- variables [topological_space X'] [topological_space Y] [topological_space Z]
variables {E : Type*} [normed_add_comm_group E] [normed_space ℝ E]
          {F : Type*} [normed_add_comm_group F] [normed_space ℝ F]
          {F' : Type*} [normed_add_comm_group F'] [normed_space ℝ F']

set_option old_structure_cmd true

/-! ## Definition and periodicity lemmas -/

variables (X)

/-- A loop is a function with domain `ℝ` and is periodic with period 1. -/
structure loop :=
(to_fun : ℝ → X)
(per' : ∀ t, to_fun (t + 1) = to_fun t)

instance : has_coe_to_fun (loop X) (λ _, ℝ → X) := ⟨λ γ, γ.to_fun⟩

initialize_simps_projections loop (to_fun → apply)

/-- Any function `φ : α → loop X` can be seen as a function `α × ℝ → X`. -/
instance has_uncurry_loop {α : Type*} : has_uncurry (α → loop X) (α × ℝ) X := ⟨λ φ p, φ p.1 p.2⟩

variables {X}

namespace loop

@[simp]
protected lemma coe_mk {γ : ℝ → X} (h : ∀ t, γ (t + 1) = γ t) : ⇑(⟨γ, h⟩ : loop X) = γ :=
rfl

@[ext] protected lemma ext : ∀ {γ₁ γ₂ : loop X}, (γ₁ : ℝ → X) = γ₂ → γ₁ = γ₂
| ⟨x, h1⟩ ⟨.(x), h2⟩ rfl := rfl

protected lemma ext_iff {γ₁ γ₂ : loop X} : γ₁ = γ₂ ↔ (γ₁ : ℝ → X) = γ₂ :=
⟨λ h, by rw h, loop.ext⟩

/-- The constant loop. -/
@[simps]
def const (f : X) : loop X :=
⟨λ t, f, λ t, rfl⟩

instance [has_zero X] : has_zero (loop X) :=
⟨const 0⟩

@[simp] lemma zero_fun [has_zero X] : ((0 : loop X) : ℝ → X) = (0 : ℝ → X) :=
rfl

-- unused
@[simp] lemma const_zero [has_zero X] : const (0 : X) = (0 : loop X) :=
rfl

instance [inhabited X] : inhabited (loop X) :=
⟨loop.const default⟩

/-- Periodicity of loops restated in terms of the function coercion. -/
lemma per (γ : loop X) : ∀ t, γ (t + 1) = γ t :=
loop.per' γ

lemma periodic (γ : loop X) : function.periodic γ 1 :=
loop.per' γ

protected lemma one (γ : loop X) : γ 1 = γ 0 :=
by { convert γ.per 0, rw [zero_add] }

-- unused
lemma add_nat_eq (γ : loop X) (t : ℝ) : ∀ (n : ℕ), γ (t + n) = γ t
| 0 := by rw [nat.cast_zero, add_zero]
| (nat.succ n) := by rw [← add_nat_eq n, nat.cast_succ, ← add_assoc, γ.per]

lemma add_int_eq (γ : loop X) (t : ℝ) (n : ℤ) : γ (t + n) = γ t :=
begin
  induction n using int.induction_on with n hn n hn,
  { norm_cast, rw add_zero },
  { rw [← hn, int.cast_add, ← add_assoc, int.cast_one, γ.per] },
  { rw [← hn, int.cast_sub, add_sub, int.cast_one, ← γ.per, sub_add_cancel] }
end

lemma fract_eq (γ : loop X) : ∀ t, γ (fract t) = γ t :=
begin
  intro t,
  unfold fract,
  rw [sub_eq_add_neg, ← int.cast_neg],
  exact γ.add_int_eq _ _
end

lemma range_eq_image (γ : loop X) : range γ = γ '' I :=
begin
  apply eq_of_subset_of_subset,
  { rw range_subset_iff,
    exact λ y, ⟨fract y, unit_interval.fract_mem y, γ.fract_eq _⟩ },
  { rintros y ⟨x, hx, hxy⟩,
    exact ⟨x, hxy⟩ },
end

/-- Transforming a loop by applying function `f`. -/
@[simps]
def transform (γ : loop X) (f : X → X') : loop X' :=
⟨λ t, f (γ t), λ t, by rw γ.per⟩

/-- Adding two loops pointwise. -/
@[simps]
instance [has_add X] : has_add (loop X) :=
⟨λ γ₁ γ₂, ⟨λ t, γ₁ t + γ₂ t, λ t, by simp_rw [loop.per]⟩⟩

@[simps]
instance [has_neg X] : has_neg (loop X) :=
⟨λ γ, ⟨λ t, - γ t, λ t, by simp_rw [loop.per]⟩⟩

instance [add_comm_group X] : add_comm_group (loop X) :=
{ add_assoc := λ γ₁ γ₂ γ₃, by { ext t, apply add_assoc },
  add_comm := λ γ₁ γ₂, by { ext t, apply add_comm },
  add_comm := λ γ₁ γ₂, by { ext t, apply add_comm },
  zero_add := λ γ, by { ext t, apply zero_add },
  add_zero := λ γ, by { ext t, apply add_zero },
  add_left_neg := λ γ, by { ext t, apply add_left_neg },
  ..loop.has_add,
  ..loop.has_zero,
  ..loop.has_neg }

/-- Shifting a loop, or equivalently, adding a constant value to a loop. -/
instance [has_add X] : has_vadd X (loop X) :=
⟨λ x γ, γ.transform (λ y, x + y)⟩

@[simp] lemma vadd_apply [has_add X] {x : X} {γ : loop X} {t : ℝ} : (x +ᵥ γ) t = x + γ t :=
rfl

/-- Multiplying a loop by a scalar value. -/
instance [has_smul K X] : has_smul K (loop X) :=
⟨λ k γ, γ.transform (λ y, k • y)⟩

instance [semiring K] [add_comm_group X] [module K X] : module K (loop X) :=
{ one_smul := λ γ, by { ext t, apply one_smul },
  mul_smul := λ k₁ k₂ γ, by { ext t, apply mul_smul },
  smul_zero := λ k, by { ext t, apply smul_zero },
  smul_add := λ k γ₁ γ₂, by { ext t, apply smul_add },
  add_smul := λ k₁ k₂ γ, by { ext t, apply add_smul },
  zero_smul := λ γ, by { ext t, apply zero_smul } }

@[simp] lemma smul_apply [has_smul K X] {k : K} {γ : loop X} {t : ℝ} : (k • γ) t = k • γ t :=
rfl

-- unused
lemma norm_at_le_supr_norm_Icc (γ : loop F) (hγ : continuous γ) (t : ℝ) :
  ‖γ t‖ ≤ ⨆ (s : I), ‖γ s‖ :=
begin
  obtain ⟨u, hu, ht⟩ := γ.periodic.exists_mem_Ico₀ zero_lt_one t,
  replace hu := mem_Icc_of_Ico hu,
  rw ht,
  have h₁ : set.nonempty (range (λ (s : I), ‖γ s‖)) := ⟨‖γ 0‖, 0, rfl⟩,
  have h₂ : bdd_above (range (λ (s : I), ‖γ s‖)),
  { convert is_compact_Icc.bdd_above_image (continuous_norm.comp hγ).continuous_on, ext, simp, },
  exact (real.is_lub_Sup _ h₁ h₂).1 ⟨⟨u, hu⟩, rfl⟩,
end

/-- Reparametrizing loop `γ` using an equivariant map `φ`. -/
@[simps {simp_rhs := tt}]
def reparam {F : Type*} (γ : loop F) (φ : equivariant_map) : loop F :=
{ to_fun := γ ∘ φ,
  per' := λ t, by rw [comp_apply, φ.eqv, γ.per] }

/-! ## Support of a loop family -/

/-- A loop is constant if it takes the same value at every time.
See also `loop.is_const_iff_forall_avg` and `loop.is_const_iff_const_avg` for characterizations in
terms of average values. -/
def is_const (γ : loop X) := ∀ t s, γ t = γ s

lemma is_const_of_eq {γ : loop X} {f : X} (H : ∀ t, γ t = f) : γ.is_const :=
λ t t', by rw [H, H]

variables [topological_space X] [topological_space X']
variables [topological_space Y] [topological_space Z]

/-- The support of a loop family is the closure of the set of parameters where
the loop is not constant. -/
def support (γ : X → loop X') : set X :=
closure {x | ¬ (γ x).is_const}

lemma not_mem_support {γ : X → loop X'} {x : X} (h : ∀ᶠ y in 𝓝 x, (γ y).is_const) :
  x ∉ loop.support γ :=
begin
  intro hx,
  rw [support, mem_closure_iff_nhds] at hx,
  rcases hx _ h with ⟨z, hz, hz'⟩,
  exact hz' hz
end

/-! ## From paths to loops -/

/-- Turn a path into a loop. -/
@[simps]
noncomputable def of_path {x : X} (γ : path x x) : loop X :=
{ to_fun := λ t, γ.extend (fract t),
  per' :=
  begin
    intros t,
    congr' 1,
    exact_mod_cast fract_add_int t 1
  end }

@[simp]
lemma range_of_path {x : X} (γ : path x x) : range (of_path γ) = range γ :=
begin
  rw loop.range_eq_image,
  unfold_coes,
  simp only [of_path, image_eq_range],
  congr,
  ext t,
  by_cases ht1 : t.val = 1,
  { have : t = ⟨1, right_mem_Icc.mpr zero_le_one⟩ := subtype.ext_val ht1,
    rw this,
    norm_cast,
    simp only [fract, floor_one, path.extend_zero, int.cast_one, sub_self, subtype.coe_mk],
    exact γ.target.symm },
  { change (t : ℝ) ≠ 1 at ht1,
    have : fract ↑t = t.val,
    { rw fract_eq_iff,
      refine ⟨t.2.1, t.2.2.lt_of_ne ht1, ⟨0, _⟩⟩,
      rw [int.cast_zero, subtype.val_eq_coe, sub_self] },
    simp only [this, γ.extend_extends t.2],
    congr',
    rw subtype.ext_iff_val }
end

/-- `loop.of_path` is continuous, general version. -/
lemma _root_.continuous.of_path (x : X → Y) (t : X → ℝ)
  (γ : ∀ i, path (x i) (x i)) (hγ : continuous ↿γ) (ht : continuous t) :
  continuous (λ i, of_path (γ i) (t i)) :=
begin
  change continuous (λ i, (λ s, (γ s).extend) i (fract (t i))),
  refine continuous_on.comp_fract _ ht _,
  { exact (hγ.comp (continuous_id.prod_map continuous_proj_Icc)).continuous_on },
  { simp only [Icc.mk_zero, zero_le_one, path.target, path.extend_extends,
      implies_true_iff, eq_self_iff_true, path.source, right_mem_Icc, left_mem_Icc,
      Icc.mk_one] }
end

/-- `loop.of_path` is continuous, where the endpoints of `γ` are fixed. TODO: remove -/
lemma of_path_continuous_family {x : Y} (γ : X → path x x)
  (h : continuous ↿γ) : continuous ↿(λ s, of_path $ γ s) :=
continuous.of_path _ _ (λ i : X × ℝ, γ i.1) (h.comp $ continuous_fst.prod_map continuous_id)
  continuous_snd

/-! ## Round trips -/

/-- The round-trip defined by `γ` is `γ` followed by `γ⁻¹`. -/
def round_trip {x y : X} (γ : path x y) : loop X :=
of_path (γ.trans γ.symm)

lemma round_trip_range {x y : X} {γ : path x y} : range (round_trip γ) = range γ :=
by simp [round_trip, range_of_path, path.trans_range, path.symm_range]

lemma round_trip_based_at {x y : X} {γ : path x y} : round_trip γ 0 = x :=
begin
  unfold_coes,
  rw [round_trip, of_path],
  simp [fract_zero]
end

lemma round_trip_eq {x y x' y' : X} {γ : path x y} {γ' : path x' y'} (h : ∀ s, γ s = γ' s) :
  round_trip γ = round_trip γ' :=
begin
  obtain rfl : x = x' := γ.source.symm.trans ((h 0).trans γ'.source),
  obtain rfl : y = y' := γ.target.symm.trans ((h 1).trans γ'.target),
  obtain rfl : γ = γ', { ext, apply h },
  refl,
end

/-- The round trip loop family associated to a path `γ`. For each parameter `t`,
the loop `round_trip_family γ t` backtracks at `γ t`. -/
noncomputable
def round_trip_family {x y : X} (γ : path x y) : ℝ → loop X :=
have key : ∀ {t}, x = γ.extend (min 0 t) := λ t, (γ.extend_of_le_zero $ min_le_left _ _).symm,
λ t, round_trip ((γ.truncate 0 t).cast key rfl)

lemma round_trip_family_continuous {x y : X} {γ : path x y} : continuous ↿(round_trip_family γ) :=
of_path_continuous_family _
  (path.trans_continuous_family _ (γ.truncate_const_continuous_family 0) _ $
    path.symm_continuous_family _ $ γ.truncate_const_continuous_family 0)

lemma round_trip_family_based_at {x y : X} {γ : path x y} : ∀ t, (round_trip_family γ) t 0 = x :=
λ t, round_trip_based_at

lemma round_trip_family_zero {x y : X} {γ : path x y} :
  (round_trip_family γ) 0 = of_path (path.refl x) :=
begin
  simp only [round_trip_family, round_trip, path.truncate_zero_zero, of_path],
  ext z,
  congr,
  ext t,
  simp [path.refl_symm]
end

lemma round_trip_family_one {x y : X} {γ : path x y} : (round_trip_family γ) 1 = round_trip γ :=
begin
  simp only [round_trip_family, round_trip, path.truncate_zero_one, of_path],
  refl
end

section average

/-! ## Average value of a loop -/

variables [measurable_space F] [borel_space F] [second_countable_topology F] [complete_space F]

/-- The average value of a loop. -/
noncomputable def average (γ : loop F) : F :=
∫ x in 0..1, (γ x)

-- unused
@[simp]
lemma zero_average : average (0 : loop F) = 0 :=
interval_integral.integral_zero

lemma is_const_iff_forall_avg {γ : loop F} : γ.is_const ↔ ∀ t, γ t = γ.average :=
begin
  split ; intro h,
  { intro t,
    have : γ = loop.const (γ t),
    { ext s,
      rw h s t,
      refl },
    rw this,
    simp only [average, const_apply, interval_integral.integral_const, one_smul, sub_zero], },
  { exact is_const_of_eq h }
end

@[simp] lemma average_const {f : F} : (const f).average = f :=
by simp [loop.average]

open measure_theory
@[simp] lemma average_add {γ₁ γ₂ : loop F} (hγ₁ : interval_integrable γ₁ volume 0 1)
  (hγ₂ : interval_integrable γ₂ volume 0 1) : (γ₁ + γ₂).average = γ₁.average + γ₂.average :=
by simp [loop.average, interval_integral.integral_add hγ₁ hγ₂]

@[simp] lemma average_smul {γ : loop F} {c : ℝ} : (c • γ).average = c • γ.average :=
by simp [loop.average, interval_integral.integral_smul]

lemma is_const_iff_const_avg {γ : loop F} : γ.is_const ↔ γ = const γ.average :=
by { rw [loop.is_const_iff_forall_avg, loop.ext_iff, funext_iff], refl }

lemma is_const_of_not_mem_support {γ : X → loop F} {x : X}
  (hx : x ∉ support γ) : (γ x).is_const :=
begin
  classical,
  exact decidable.by_contradiction (λ H, hx (subset_closure H)),
end

lemma continuous_average {E : Type*} [topological_space E] [first_countable_topology E]
  [locally_compact_space E] {γ : E → loop F}
  (hγ_cont : continuous ↿γ) : continuous (λ x, (γ x).average) :=
continuous_parametric_interval_integral_of_continuous' hγ_cont _ _

/-- The normalization of a loop `γ` is the loop `γ - γ.average`. -/
def normalize (γ : loop F) : loop F :=
{ to_fun := λ t, γ t - γ.average,
  per' := λ t, by simp [γ.per] }

@[simp]
lemma normalize_apply (γ : loop F) (t : ℝ) : loop.normalize γ t = γ t - γ.average :=
rfl

@[simp]
lemma normalize_of_is_const {γ : loop F} (h : γ.is_const) : γ.normalize = 0 :=
begin
  ext t,
  simp [is_const_iff_forall_avg.mp h]
end

end average

end loop

section c1

/-! ## Differentiation of loop families -/

local notation `∂₁` := partial_fderiv_fst ℝ

variables (π : E → ℝ) (N : ℝ) (γ : E → loop F)
          (hγ : is_compact (loop.support γ))

/-- Differential of a loop family with respect to the parameter. -/
def loop.diff (γ : E → loop F) (e : E) : loop (E →L[ℝ] F) :=
{ to_fun := λ t, ∂₁ (λ e t, γ e t) e t,
  per' := λ t, by simp only [partial_fderiv_fst, loop.per] }

@[simp]
lemma loop.diff_apply (γ : E → loop F) (e : E) (t : ℝ) : loop.diff γ e t = ∂₁ (λ e t, γ e t) e t :=
rfl

lemma loop.continuous_diff {γ : E → loop F} (h : 𝒞 1 ↿γ) : continuous (↿(loop.diff γ)) :=
cont_diff.continuous_partial_fst (h : _)

lemma cont_diff.partial_loop {γ : E → loop F} {n : ℕ∞} (hγ_diff : 𝒞 n ↿γ) :
  ∀ t, 𝒞 n (λ e, γ e t) :=
λ t, hγ_diff.comp ((cont_diff_prod_mk_left t).of_le le_top)

variables [measurable_space F] [borel_space F] [finite_dimensional ℝ F]

lemma loop.support_diff {γ : E → loop F} :
  loop.support (loop.diff γ) ⊆ loop.support γ :=
begin
  unfold loop.support,
  erw [closure_compl, closure_compl],
  rw compl_subset_compl,
  intros x hx,
  rw mem_interior_iff_mem_nhds at *,
  rcases mem_nhds_iff.mp hx with ⟨U, hU, U_op, hxU⟩,
  have U_nhds : U ∈ 𝓝 x, from is_open.mem_nhds U_op hxU,
  apply filter.mem_of_superset U_nhds,
  intros y hy,
  have Hy : ∀ t, (λ z, γ z t) =ᶠ[𝓝 y] (λ z, (γ z).average),
  { intro t,
    apply filter.mem_of_superset (U_op.mem_nhds hy),
    intros z hz,
    exact loop.is_const_iff_forall_avg.mp (hU hz) t },
  have : ∀ (t : ℝ), loop.diff γ y t = D (λ (z : E), (γ z).average) y := λ t, (Hy t).fderiv_eq,
  intros t s,
  simp [this]
end

variables [finite_dimensional ℝ E]

lemma loop.average_diff {γ : E → loop F} (hγ_diff : 𝒞 1 ↿γ) (e : E) :
(loop.diff γ e).average = D (λ e, (γ e).average) e :=
begin
  change 𝒞 1 ↿(λ (e : E) (t : ℝ), γ e t) at hγ_diff,
  simpa only [loop.average, hγ_diff.fderiv_parametric_integral]
end

lemma cont_diff.loop_average {γ : E → loop F} {n : ℕ∞} (hγ_diff : 𝒞 n ↿γ) :
  𝒞 n (λ e, (γ e).average) :=
cont_diff_parametric_integral_of_cont_diff hγ_diff _ _

lemma loop.diff_normalize {γ : E → loop F} (hγ_diff : 𝒞 1 ↿γ) (e : E) :
  (loop.diff γ e).normalize = loop.diff (λ e, (γ e).normalize) e :=
begin
  ext t x,
  simp only [loop.diff_apply, loop.normalize_apply, partial_fderiv_fst],

  rw [fderiv_sub ((hγ_diff.partial_loop t).differentiable le_rfl).differentiable_at,
      loop.average_diff hγ_diff],
  exact (hγ_diff.loop_average.differentiable le_rfl).differentiable_at
end

variable {γ}

lemma cont_diff_average {n : ℕ∞} (hγ_diff : 𝒞 n ↿γ) : 𝒞 n (λ x, (γ x).average) :=
cont_diff_parametric_primitive_of_cont_diff hγ_diff cont_diff_const 0

lemma cont_diff_sub_average {n : ℕ∞} (hγ_diff : 𝒞 n ↿γ) :
  𝒞 n ↿(λ (x : E) (t : ℝ), (γ x) t - (γ x).average) :=
hγ_diff.sub (cont_diff_average hγ_diff).fst'

end c1


-- Copyright (C) 2020 by @ljt12138

import tactic pal.henkin_model pal.soundness

namespace pal_logic

def trivial_world (α agent : Type) : worlds α agent ℕ :=
{
  f := λ s a, false,
  view := λ i s t, s = t,
  equiv :=
  begin intros i, simp, apply eq_equivalence end
}

theorem completeness {α agent : Type} [encodable (sentence α agent)]
  (φ : sentence α agent) : static φ → ⊨ φ → ⊢ φ :=
begin
  intros st h, classical, by_contra,
  have h₁ : consistent_set (λ ψ, ψ = φ↣⊥),
  {
    simp, intros Γ h' contra, apply a,
    have h₂ : ⊢ conjunction [φ↣⊥] ↣ ⊥,
    {
      cases contra with pf pfh,
      existsi proof.conj Γ [φ↣⊥] ⊥ pf _, { prover },
      intros ψ h₁, rewrite h' _ h₁, simp
    },
    simp at h₂, cases h₂,
    existsi proof.mp (proof.ax3 _) _, prover
  },
  cases dcomplete_extension (λ ψ, ψ = φ↣⊥) h₁ with s h₂,
  have st' : static (φ↣⊥),
  { apply static.imply, exact st, apply static.perp },
  have h₂ : ⦃s⦄ ⊨ φ ↣ ⊥,
  {
    apply (henkin_correctness (φ↣⊥) st' s).mp,
    apply h₂, reflexivity
  },
  simp at h₂, apply h₂, apply h
end

end pal_logic


import topology.algebra.module.basic

open filter continuous_linear_map function
open_locale topology big_operators filter

namespace continuous_linear_map

variables {R₁ M₁ M₂ M₃ : Type*} [semiring R₁]
variables [topological_space M₁] [add_comm_monoid M₁]
variables [topological_space M₂] [add_comm_monoid M₂]
variables [topological_space M₃] [add_comm_monoid M₃]
variables [module R₁ M₁] [module R₁ M₂] [module R₁ M₃]

-- unused
lemma comp_fst_add_comp_snd [has_continuous_add M₃] (f : M₁ →L[R₁] M₃) (g : M₂ →L[R₁] M₃) :
  f.comp (continuous_linear_map.fst R₁ M₁ M₂) +
  g.comp (continuous_linear_map.snd R₁ M₁ M₂) =
  f.coprod g :=
rfl

lemma fst_prod_zero_add_zero_prod_snd [has_continuous_add M₁] [has_continuous_add M₂] :
  (continuous_linear_map.fst R₁ M₁ M₂).prod 0 +
  continuous_linear_map.prod 0 (continuous_linear_map.snd R₁ M₁ M₂) =
  continuous_linear_map.id R₁ (M₁ × M₂) :=
begin
  rw [continuous_linear_map.ext_iff],
  intro x,
  simp_rw [continuous_linear_map.add_apply, continuous_linear_map.id_apply,
    continuous_linear_map.prod_apply, continuous_linear_map.coe_fst',
    continuous_linear_map.coe_snd', continuous_linear_map.zero_apply, prod.mk_add_mk, add_zero,
    zero_add, prod.mk.eta]
end

end continuous_linear_map

variables {R₁ : Type*} {R₂ : Type*} {R₃ : Type*} [semiring R₁] [semiring R₂] [semiring R₃]
{σ₁₂ : R₁ →+* R₂} {σ₂₁ : R₂ →+* R₁} [ring_hom_inv_pair σ₁₂ σ₂₁] [ring_hom_inv_pair σ₂₁ σ₁₂]
{σ₂₃ : R₂ →+* R₃} {σ₃₂ : R₃ →+* R₂} [ring_hom_inv_pair σ₂₃ σ₃₂] [ring_hom_inv_pair σ₃₂ σ₂₃]
{σ₁₃ : R₁ →+* R₃} {σ₃₁ : R₃ →+* R₁} [ring_hom_inv_pair σ₁₃ σ₃₁] [ring_hom_inv_pair σ₃₁ σ₁₃]
[ring_hom_comp_triple σ₁₂ σ₂₃ σ₁₃] [ring_hom_comp_triple σ₃₂ σ₂₁ σ₃₁]
{M₁ : Type*} [topological_space M₁] [add_comm_monoid M₁]
{M'₁ : Type*} [topological_space M'₁] [add_comm_monoid M'₁]
{M₂ : Type*} [topological_space M₂] [add_comm_monoid M₂]
{M₃ : Type*} [topological_space M₃] [add_comm_monoid M₃]
{M₄ : Type*} [topological_space M₄] [add_comm_monoid M₄]
[module R₁ M₁] [module R₁ M'₁] [module R₂ M₂] [module R₃ M₃]

section
include σ₁₃
lemma function.surjective.clm_comp_injective {g : M₁ →SL[σ₁₂] M₂}
  (hg : function.surjective g) : function.injective (λ f : M₂ →SL[σ₂₃] M₃, f.comp g) :=
begin
  intros f f' hff',
  rw [continuous_linear_map.ext_iff] at hff' ⊢,
  intros x,
  obtain ⟨y, rfl⟩ := hg x,
  exact hff' y,
end
end

namespace continuous_linear_equiv

include σ₂₁ σ₁₃
theorem cancel_right {f f' : M₂ →SL[σ₂₃] M₃} {e : M₁ ≃SL[σ₁₂] M₂} :
  f.comp (e : M₁ →SL[σ₁₂] M₂) = f'.comp (e : M₁ →SL[σ₁₂] M₂) ↔ f = f' :=
begin
  split,
  { simp_rw [continuous_linear_map.ext_iff, continuous_linear_map.comp_apply, coe_coe],
    intros h v, rw [← e.apply_symm_apply v, h] },
  { rintro rfl, refl }
end

omit σ₂₁
include σ₃₂

theorem cancel_left {e : M₂ ≃SL[σ₂₃] M₃} {f f' : M₁ →SL[σ₁₂] M₂} :
  (e : M₂ →SL[σ₂₃] M₃).comp f = (e : M₂ →SL[σ₂₃] M₃).comp f' ↔ f = f' :=
begin
  split,
  { simp_rw [continuous_linear_map.ext_iff, continuous_linear_map.comp_apply, coe_coe],
    intros h v, rw [← e.symm_apply_apply (f v), h, e.symm_apply_apply] },
  { rintro rfl, refl }
end

omit σ₃₂

end continuous_linear_equiv


import number_theory.cyclotomic.Unit_lemmas
import number_theory.cyclotomic.cycl_rat
import number_theory.regular_primes
import number_theory.cyclotomic.factoring

open_locale number_field non_zero_divisors

variables {p : ℕ+} {K : Type*} [field K] [char_zero K] [is_cyclotomic_extension {p} ℚ K]
variables {ζ : K} (hζ : is_primitive_root ζ p)

open fractional_ideal

variable (i : ℤ)

namespace flt_regular.caseI

lemma exists_int_sum_eq_zero (hpodd : p ≠ 2) [hp : fact(p : ℕ).prime] {x y i : ℤ} {u : (𝓞 K)ˣ}
  {α : 𝓞 K} (h : (x : 𝓞 K) + y * (hζ.unit' ^ i : (𝓞 K)ˣ) = u * α ^ (p : ℕ)) :
  ∃ k : ℤ, (x : 𝓞 K) + y * (hζ.unit' ^ i : (𝓞 K)ˣ) - (hζ.unit' ^ (2 * k) : (𝓞 K)ˣ) *
    (x + y * (hζ.unit' ^ -i : (𝓞 K)ˣ)) ∈ ideal.span ({p} : set (𝓞 K)) :=
begin
  letI : number_field K := is_cyclotomic_extension.number_field {p} ℚ _,
  obtain ⟨β, k, hβreal : gal_conj K p β = β, H⟩ := unit_lemma_gal_conj hζ hpodd hp.out u,
  have : ((x + y * (hζ.unit' ^ -i : (𝓞 K)ˣ)) : K) = gal_conj K p (x + y * hζ.unit' ^ i),
  { simp [gal_conj_zeta_runity hζ, ← coe_life] },
  obtain ⟨a, ha⟩ := exists_int_sub_pow_prime_dvd p α,
  refine ⟨k, _⟩,
  rw [ideal.mem_span_singleton] at ha ⊢,
  obtain ⟨γ, hγ⟩ := ha,
  rw [h, sub_eq_iff_eq_add.1 hγ, mul_add, ← mul_assoc, mul_comm ↑u, mul_assoc, add_sub_assoc],
  refine dvd_add (dvd.intro _ rfl) _,
  have h' := congr_arg (coe : 𝓞 K → K) h,
  have hγ' := congr_arg (coe : 𝓞 K → K) hγ,
  simp only [add_subgroup_class.coe_sub, subsemiring_class.coe_pow, subring_class.coe_int_cast,
    mul_mem_class.coe_mul, subring_class.coe_nat_cast, add_mem_class.coe_add, coe_zpow'] at h' hγ',
  rw [h', sub_eq_iff_eq_add.1 hγ', H, mul_mem_class.coe_mul, alg_equiv.map_mul, alg_equiv.map_mul,
    alg_equiv.map_add, map_int_cast, alg_equiv.map_mul, ← coe_coe β, coe_zpow', map_zpow₀, coe_coe,
    coe_zpow'] at this,
  simp only [coe_coe, hζ.coe_unit'_coe, subring_class.coe_nat_cast, map_nat_cast] at this,
  let γ' := (⟨gal_conj K p γ, number_field.ring_of_integers.map_mem (gal_conj K p) γ⟩ : 𝓞 K),
  have hint : ↑γ' = gal_conj K p γ := rfl,
  rw [← coe_coe β, hβreal, gal_conj_zeta_runity hζ, ← hζ.coe_unit'_coe, inv_zpow, ← zpow_neg,
    coe_coe, ← hint, ← subring_class.coe_int_cast (𝓞 K) x, ← subring_class.coe_int_cast (𝓞 K) y,
    ← coe_coe, ← coe_zpow', ← subring_class.coe_nat_cast (𝓞 K) p, ← coe_zpow',
    ← subring_class.coe_int_cast (𝓞 K) a, ← mul_mem_class.coe_mul (𝓞 K),
    ← add_mem_class.coe_add (𝓞 K), ← mul_mem_class.coe_mul (𝓞 K), ← mul_mem_class.coe_mul (𝓞 K),
    ← add_mem_class.coe_add (𝓞 K), ← mul_mem_class.coe_mul (𝓞 K), subtype.coe_inj] at this,
  rw [this, mul_add, mul_add, sub_add_eq_sub_sub, sub_right_comm],
  refine dvd_sub _ (by simp),
  rw [mul_comm ↑β, ← mul_assoc, ← mul_assoc, ← units.coe_mul, ← zpow_add, two_mul,
    ← sub_eq_add_neg, add_sub_assoc, sub_self, add_zero, mul_comm _ ↑β, ← H, sub_self],
  exact dvd_zero _
end

end flt_regular.caseI


-- The Category 5 Diamond.

-- Notes by Kevin Buzzard made whilst trying to understand
-- why Lean can sometimes be so stupid about the obvious
-- ring structures all being equal

-- Xena. Prove a theorem. Write a function.

--------------------------------------------------------------

import tactic.interactive -- only needed if you want Floris' rintro on the last line

namespace xena

class A := (n : ℕ)
class B := (n : ℕ)
class C := (n : ℕ)
class D := (n : ℕ)

-- the classic type class inference diamond

-- Lean I wish I didn't have to name these instances.
-- can something be done about this in the fork?
instance AtoB [hAB : A] : B := ⟨hAB.n + 1⟩
instance BtoD [hBD : B] : D := ⟨hBD.n + 10⟩
instance AtoC [hAC : A] : C := ⟨hAC.n + 100⟩
instance CtoD [hCD : C] : D := ⟨hCD.n + 1000⟩

instance a : A := ⟨37⟩

-- can we get type class inference to make to distinct elments of D for us?

def b : B := by apply_instance
def c : C := by apply_instance
-- d1 promises that they are the type class inference system's intended
-- term, because they were generated with `by apply_instance`
def d1 : D := by apply_instance -- who will win the race around the square?
#print d1 -- xena.CtoD won
#check xena.BtoD -- the loser
attribute [instance, priority 10000] xena.BtoD -- give it some juice
-- d2 promises that they are the type class inference system's intended
-- term, because they were generated with `by apply_instance`
def d2 : D := by apply_instance
#print d2 -- rofl BtoD won this time

theorem you_are_in_typeclass_trouble_now : d1 ≠ d2 :=
begin
  intro h,
    unfold d1 at h,
  unfold d2 at h,
  unfold xena.CtoD at h,
  unfold xena.BtoD at h,
  unfold C.n at h,
  unfold B.n at h,
  unfold A.n at h,
  cases h,
end

-- Thanks to Floris van Doorn for showing me this very pretty proof
-- (although )
theorem thanks_to_Floris_van_Doorn : d1 ≠ d2 := by rintro ⟨⟩

end xena


import tactic
import tactic.induction
import data.int.basic
import data.set.basic

import .base .point .dist .board .state

noncomputable theory
open_locale classical

instance {b : Board} : inhabited (Valid_D_move b) :=
⟨⟨none, trivial⟩⟩

-----

instance {pw : ℕ} : inhabited (A pw) :=
⟨⟨λ s hs h, ⟨h.some, h.some_spec⟩⟩⟩

instance : inhabited D :=
⟨⟨λ s hs, ⟨none, trivial⟩⟩⟩

def A.sup {pw pw₁ : ℕ} (a₁ : A pw₁) (a : A pw) : Prop :=
∀ s hs h, ∃ hs₁ h₁, (a₁.f s hs₁ h₁).m = (a.f s hs h).m

def A.sub {pw₁ pw : ℕ} (a : A pw₁) (a₁ : A pw) : Prop :=
a₁.sup a

def A_prev_moves (pw : ℕ) (s : State) :=
Π (s₁ : State), s₁.act → s₁.len < s.len →
A_has_valid_move pw s₁.board → Valid_A_move pw s₁.board

def D_prev_moves (s : State) :=
Π (s₁ : State), s₁.act → s₁.len < s.len →
Valid_D_move s₁.board

def A.set_prev_moves {pw : ℕ} (a : A pw) (s : State)
  (pm : A_prev_moves pw s) : A pw :=
begin
  refine ⟨λ s₁ hs h₁, _⟩,
  apply dite (s₁.len < s.len); intro h₂,
  { exact pm s₁ hs h₂ h₁ },
  { exact a.f s₁ hs h₁ },
end

def D.set_prev_moves (d : D) (s : State)
  (pm : D_prev_moves s) : D :=
begin
  refine ⟨λ s₁ hs, _⟩,
  apply dite (s₁.len < s.len); intro h₁,
  { exact pm s₁ hs h₁ },
  { exact d.f s₁ hs },
end

def A.set_move {pw : ℕ} (a : A pw) (s : State)
  (ma : Valid_A_move pw s.board) : A pw :=
begin
  refine ⟨λ s₁ hs h, _⟩, apply dite (s₁ = s); intro h₁,
  { cases h₁, exact ma },
  { exact a.f s₁ hs h },
end

def D.set_move (d : D) (s : State)
  (md : Valid_D_move s.board) : D :=
begin
  refine ⟨λ s₁ hs, _⟩, apply dite (s₁ = s); intro h₁,
  { cases h₁, exact md },
  { exact d.f s₁ hs },
end

def A.prev_moves_id {pw : ℕ} (a : A pw) (s : State) : A pw :=
a.set_prev_moves s (λ s₁ hs _ h, a.f s₁ hs h)

def D.prev_moves_id (d : D) (s : State) : D :=
d.set_prev_moves s (λ s₁ hs h, d.f s₁ hs)

def A.prev_moves_set {pw : ℕ} (a : A pw) (s : State)
  (s₁ : State) (m : Valid_A_move pw s₁.board)
  (h : s₁.len < s.len) : A pw :=
begin
  apply a.set_prev_moves s, rintro s₂ hs h₁ h₂,
  apply dite (s₂ = s₁); intro h₃,
  { cases h₃, exact m },
  { exact a.f s₂ hs h₂ },
end

def D.prev_moves_set (d : D) (s : State)
  (s₁ : State) (m : Valid_D_move s₁.board)
  (h : s₁.len < s.len) : D :=
begin
  apply d.set_prev_moves s, rintro s₂ hs h₁,
  apply dite (s₂ = s₁); intro h₂,
  { cases h₂, exact m },
  { exact d.f s₂ hs },
end

def A_state (s : State) : Prop := odd s.len
def D_state (s : State) : Prop := even s.len

-----

lemma A_move_valid_ge_of {pw pw₁ : ℕ} {b : Board} {p : A_move}
  (h₁ : pw ≤ pw₁) (h₂ : A_move_valid pw b p) :
  A_move_valid pw₁ b p :=
⟨h₂.1, h₂.2.1.trans h₁, h₂.2.2⟩

lemma A_has_valid_move_ge_of {pw pw₁ : ℕ} {b : Board}
  (h₁ : pw ≤ pw₁) (h₂ : A_has_valid_move pw b) :
  A_has_valid_move pw₁ b :=
by { cases h₂ with m h₂, use m, exact A_move_valid_ge_of h₁ h₂ }

lemma As_eq_iff {pw : ℕ} {a₁ a₂ : A pw} :
  a₁ = a₂ ↔ ∀ s hs h, a₁.f s hs h = a₂.f s hs h :=
begin
  split; intro h,
  { subst h, simp },
  { cases a₁ with f₁, cases a₂ with f₂, congr, ext, apply h },
end

lemma Ds_eq_iff {d₁ d₂ : D} :
  d₁ = d₂ ↔ ∀ s hs, d₁.f s hs = d₂.f s hs :=
begin
  split; intro h,
  { subst h, simp },
  { cases d₁ with f₁, cases d₂ with f₂, congr, ext, apply h },
end

lemma A_prev_moves_id_eq {pw : ℕ} {a : A pw} {s : State} :
  a.prev_moves_id s = a :=
by { rw As_eq_iff, rintro s₁ hs h, change dite _ _ _ = _, split_ifs; refl }

lemma D_prev_moves_id_eq {d : D} {s : State} :
  d.prev_moves_id s = d :=
by { rw Ds_eq_iff, rintro s₁ hs, change dite _ _ _ = _, split_ifs; refl }

@[simp]
lemma A_set_move_eq {pw : ℕ} {a : A pw}
  {s : State} {m : Valid_A_move pw s.board} {hs h} :
  (a.set_move s m).f s hs h = m :=
by { change dite _ _ _ = _, split_ifs with h₁; refl }

@[simp]
lemma D_set_move_eq {d : D}
  {s : State} {m : Valid_D_move s.board} {hs} :
  (d.set_move s m).f s hs = m :=
by { change dite _ _ _ = _, split_ifs with h₁; refl }

lemma A_set_move_self {pw : ℕ} {a : A pw}
  {s : State} {hs h} : a.set_move s (a.f s hs h) = a :=
begin
  rw As_eq_iff; intros, change dite _ _ _ = _, split_ifs with h₂,
  { subst h₂ }, { refl },
end

lemma D_set_move_self {d : D}
  {s : State} {hs} : d.set_move s (d.f s hs) = d :=
begin
  rw Ds_eq_iff; intros, change dite _ _ _ = _, split_ifs with h₂,
  { subst h₂ }, { refl },
end

lemma A_set_move_set_move_eq {pw : ℕ} {a : A pw} {s : State}
  {m₁ m₂ : Valid_A_move pw s.board} :
  (a.set_move s m₁).set_move s m₂ = a.set_move s m₂ :=
begin
  rw As_eq_iff, rintro s₁ hs h₁,
  change dite _ _ _ = _, split_ifs with h₂,
  { subst h₂, rw A_set_move_eq },
  { change dite _ _ _ = dite _ _ _, simp_rw dif_neg h₂ },
end

lemma D_set_move_set_move_eq {d : D} {s : State}
  {m₁ m₂ : Valid_D_move s.board} :
  (d.set_move s m₁).set_move s m₂ = d.set_move s m₂ :=
begin
  rw Ds_eq_iff, rintro s₁ hs,
  change dite _ _ _ = _, split_ifs with h₂,
  { subst h₂, rw D_set_move_eq },
  { change dite _ _ _ = dite _ _ _, simp_rw dif_neg h₂ },
end

lemma A_prev_moves_set_eq {pw : ℕ} {a : A pw} {s s₁ : State}
  {m : Valid_A_move pw s₁.board} {h} :
  a.prev_moves_set s s₁ m h = a.set_move s₁ m :=
begin
  rw As_eq_iff, rintro s₂ hs h,
  change dite _ _ _ = _, split_ifs with h₁,
  { dsimp, split_ifs with h₂,
    { subst h₂, simp [A_set_move_eq] },
    { change _ = dite _ _ _, rw dif_neg h₂ }},
  { change _ = dite _ _ _, split_ifs with h₂,
    { subst h₂, contradiction },
    { refl }},
end

lemma D_prev_moves_set_eq {d : D} {s s₁ : State}
  {m : Valid_D_move s₁.board} {h} :
  d.prev_moves_set s s₁ m h = d.set_move s₁ m :=
begin
  rw Ds_eq_iff, rintro s₂ hs,
  change dite _ _ _ = _, split_ifs with h₁,
  { dsimp, split_ifs with h₂,
    { subst h₂, simp [D_set_move_eq] },
    { change _ = dite _ _ _, rw dif_neg h₂ }},
  { change _ = dite _ _ _, split_ifs with h₂,
    { subst h₂, contradiction },
    { refl }},
end

lemma hist_len_apply_move {s : State} {b : Board} :
  (apply_move s b).len = s.len.succ :=
by { change (_ ++ [_]).length = _, rw list.length_append, refl }

lemma hist_len_apply_A_move {s : State} {ma : A_move} :
  (apply_A_move s ma).len = s.len.succ :=
hist_len_apply_move

lemma hist_len_apply_D_move {s : State} {md : D_move} :
  (apply_D_move s md).len = s.len.succ :=
hist_len_apply_move

lemma valid_A_move_ext {pw : ℕ} {b : Board}
  {ma₁ ma₂ : Valid_A_move pw b}
  (h : ma₁.m = ma₂.m) : ma₁ = ma₂ :=
by { cases ma₁, cases ma₂, congr, exact h }

lemma valid_D_move_ext {b : Board}
  {md₁ md₂ : Valid_D_move b}
  (h : md₁.m = md₂.m) : md₁ = md₂ :=
by { cases md₁, cases md₂, congr, exact h }

lemma A_moves_eq_iff' {pw : ℕ} {s : State}
  {ma₁ ma₂ : Valid_A_move pw s.board} : ma₁ = ma₂ ↔
  (apply_A_move s ma₁.m).board = (apply_A_move s ma₂.m).board :=
begin
  split; intro h, { rw h }, simp_rw [apply_A_move, apply_A_move_b, apply_move] at h,
  cases h with h₁ h₂, cases ma₁, cases ma₂, simp at h₂ ⊢, exact h₂,
end

lemma D_moves_eq_iff' {s : State}
  {md₁ md₂ : Valid_D_move s.board} : md₁ = md₂ ↔
  (apply_D_move s md₁.m).board = (apply_D_move s md₂.m).board :=
begin
  split; intro h, { rw h }, simp_rw [apply_D_move, apply_move] at h,
  cases md₁ with m₁ h₁, cases md₂ with m₂ h₂,
  apply valid_D_move_ext, dsimp at h ⊢,
  cases m₁ with p₁; cases m₂ with p₂; simp_rw apply_D_move_b at h,
  { cases h₂ with h₂ h₃, contrapose! h₃, rw h, simp },
  { cases h₁ with h₁ h₃, contrapose! h₃, rw ←h, simp },
  { replace h := h.1, replace h₁ := h₁.2, replace h₂ := h₂.2, congr,
    rw set.ext_iff at h, have h₃ := h p₁, simp at h₃, exact h₃ h₁ },
end

lemma A_moves_eq_iff {pw : ℕ} {s : State}
  {ma₁ ma₂ : Valid_A_move pw s.board} :
  ma₁ = ma₂ ↔ apply_A_move s ma₁.m = apply_A_move s ma₂.m :=
begin
  split; intro h, { rw h }, simp_rw [apply_A_move, apply_A_move_b, apply_move] at h,
  exact valid_A_move_ext h.1.2,
end

lemma D_moves_eq_iff {s : State}
  {md₁ md₂ : Valid_D_move s.board} :
  md₁ = md₂ ↔ apply_D_move s md₁.m = apply_D_move s md₂.m :=
begin
  split; intro h, { rw h }, simp_rw [apply_D_move, apply_move] at h,
  replace h := h.1, cases md₁ with m₁ h₁, cases md₂ with m₂ h₂,
  apply valid_D_move_ext, dsimp at h ⊢,
  cases m₁ with p₁; cases m₂ with p₂; simp_rw apply_D_move_b at h,
  { cases h₂ with h₂ h₃, contrapose! h₃, rw h, simp },
  { cases h₁ with h₁ h₃, contrapose! h₃, rw ←h, simp },
  { replace h := h.1, replace h₁ := h₁.2, replace h₂ := h₂.2, congr,
    rw set.ext_iff at h, have h₃ := h p₁, simp at h₃, exact h₃ h₁ },
end

lemma A_set_move_eq_pos {pw : ℕ} {a : A pw} {s : State}
  {ma : Valid_A_move pw s.board} {hs h} :
  (a.set_move s ma).f s hs h = ma :=
by { rw A.set_move, dsimp, split_ifs; refl }

lemma D_set_move_eq_pos {d : D} {s : State}
  {md : Valid_D_move s.board} {hs} :
  (d.set_move s md).f s hs = md :=
by { rw D.set_move, dsimp, split_ifs; refl }

lemma state_eq_of_apply_A_move_eq {s₁ s₂ : State}
  {ma₁ ma₂ : A_move}
  (h : apply_A_move s₁ ma₁ = apply_A_move s₂ ma₂) :
  s₁ = s₂ :=
begin
  cases s₁ with b₁ t₁ a₁, cases s₂ with b₂ t₂ a₂,
  simp_rw [apply_A_move, apply_A_move_b, apply_move] at h, simp only,
  rcases h with ⟨⟨h₁, h₂⟩, h₃, h₄⟩, rw snoc_eq_snoc_iff at h₃, cc,
end

lemma state_eq_of_apply_D_move_eq {s₁ s₂ : State}
  {ma₁ ma₂ : D_move}
  (h : apply_D_move s₁ ma₁ = apply_D_move s₂ ma₂) :
  s₁ = s₂ :=
begin
  cases s₁ with b₁ t₁ a₁, cases s₂ with b₂ t₂ a₂,
  cases ma₁ with p₁; cases ma₂ with p₂;
  simp_rw [apply_D_move, apply_D_move_b, apply_move, snoc_eq_snoc_iff] at h;
  simp only; tauto!,
end

lemma apply_move_state_nth_eq_some_of {n : ℕ} {s : State} {b sb : Board}
  (h : s.nth n = some sb) :
  (apply_move s b).nth n = some sb :=
begin
  simp_rw [State.nth, apply_move] at h ⊢, rw list.nth_append,
  { exact h },
  { rw [length_snoc, nat.lt_succ_iff], obtain ⟨h₁, h₂⟩ := list.nth_eq_some.mp h,
    rw length_snoc at h₁, exact nat.lt_succ_iff.mp h₁ },
end

lemma apply_A_move_state_nth_eq_some_of {n : ℕ}
  {s : State} {ma : A_move} {b : Board}
  (h : s.nth n = some b) :
  (apply_A_move s ma).nth n = some b :=
apply_move_state_nth_eq_some_of h

lemma apply_D_move_state_nth_eq_some_of {n : ℕ}
  {s : State} {ma : D_move} {b : Board}
  (h : s.nth n = some b) :
  (apply_D_move s ma).nth n = some b :=
apply_move_state_nth_eq_some_of h

lemma apply_move_len {s : State} {b : Board} :
  (apply_move s b).len = s.len.succ :=
length_snoc

lemma apply_A_move_len {s : State} {ma : A_move} :
  (apply_A_move s ma).len = s.len.succ :=
apply_move_len

lemma apply_D_move_len {s : State} {ma : D_move} :
  (apply_D_move s ma).len = s.len.succ :=
apply_move_len

lemma apply_D_move_b_A_eq {b : Board} {md : D_move} :
  (apply_D_move_b b md).A = b.A :=
by { cases md; refl }

lemma apply_D_move_A_eq {s : State} {md : D_move} :
  (apply_D_move s md).board.A = s.board.A :=
by { cases md; refl }

-----

def Valid_A_move_subtype (pw : ℕ) (b : Board) :=
{m : A_move // A_move_valid pw b m}

def Valid_D_move_subtype (b : Board) :=
{m : D_move // D_move_valid b m}

def Valid_A_move_equiv_subtype {pw : ℕ} {b : Board} :
  Valid_A_move pw b ≃ Valid_A_move_subtype pw b :=
begin
  fapply equiv.of_bijective, { intro ma, exact ⟨_, ma.h⟩ }, fsplit,
  { rintro ⟨m₁, h₁⟩ ⟨m2, h₂⟩ h₃, congr, exact subtype.mk.inj h₃ },
  { rintro ⟨m, h⟩, use ⟨_, h⟩ },
end

def Valid_D_move_equiv_subtype {b : Board} :
  Valid_D_move b ≃ Valid_D_move_subtype b :=
begin
  fapply equiv.of_bijective, { intro ma, exact ⟨_, ma.h⟩ }, fsplit,
  { rintro ⟨m₁, h₁⟩ ⟨m2, h₂⟩ h₃, congr, exact subtype.mk.inj h₃ },
  { rintro ⟨m, h⟩, use ⟨_, h⟩ },
end

-----

instance {pw : ℕ} {b : Board} : fintype (Valid_A_move_subtype pw b) :=
begin
  apply fintype_subtype_of_set_finite, apply set.finite.inter_of_right,
  apply set.finite.inter_of_left, change {p : Point | dist p b.A ≤ pw}.finite,
  exact dist_le_set_finite,
end

instance {pw : ℕ} {b : Board} : fintype (Valid_A_move pw b) :=
fintype.of_equiv _ Valid_A_move_equiv_subtype.symm

-----

lemma Valid_A_move_eq_iff {pw : ℕ} {b : Board}
  {ma₁ ma₂ : Valid_A_move pw b} :
  ma₁ = ma₂ ↔ ma₁.m = ma₂.m :=
by { cases ma₁, cases ma₂, simp }

lemma Valid_D_move_eq_iff {pw : ℕ} {b : Board}
  {md₁ md₂ : Valid_A_move pw b} :
  md₁ = md₂ ↔ md₁.m = md₂.m :=
by { cases md₁, cases md₂, simp }


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import category_theory.limits.shapes.pullbacks
import ring_theory.tensor_product
import algebra.category.CommRing.limits
import algebra.category.CommRing.colimits
import category_theory.limits.shapes.strict_initial
import ring_theory.subring.basic
import ring_theory.ideal.local_ring
import category_theory.limits.preserves.limits

/-!
# Constructions of (co)limits in CommRing

In this file we provide the explicit (co)cones for various (co)limits in `CommRing`, including
* tensor product is the pushout
* `Z` is the initial object
* `0` is the strict terminal object
* cartesian product is the product
* `ring_hom.eq_locus` is the equalizer

-/

universes u u'

open category_theory category_theory.limits
open_locale tensor_product

namespace CommRing

section pushout

variables {R A B : CommRing.{u}} (f : R ⟶ A) (g : R ⟶ B)

/-- The explicit cocone with tensor products as the fibered product in `CommRing`. -/
def pushout_cocone : limits.pushout_cocone f g :=
begin
  letI := ring_hom.to_algebra f,
  letI := ring_hom.to_algebra g,
  apply limits.pushout_cocone.mk,
  show CommRing, from CommRing.of (A ⊗[R] B),
  show A ⟶ _,  from algebra.tensor_product.include_left.to_ring_hom,
  show B ⟶ _,  from algebra.tensor_product.include_right.to_ring_hom,
  ext r,
  transitivity algebra_map R (A ⊗[R] B) r,
  { exact algebra.tensor_product.include_left.commutes r },
  { exact (algebra.tensor_product.include_right.commutes r).symm }
end

@[simp]
lemma pushout_cocone_inl : (pushout_cocone f g).inl = (by
{ letI := f.to_algebra, letI := g.to_algebra,
  exactI algebra.tensor_product.include_left.to_ring_hom }) := rfl

@[simp]
lemma pushout_cocone_inr : (pushout_cocone f g).inr = (by
{ letI := f.to_algebra, letI := g.to_algebra,
  exactI algebra.tensor_product.include_right.to_ring_hom }) := rfl

@[simp]
lemma pushout_cocone_X : (pushout_cocone f g).X = (by
{ letI := f.to_algebra, letI := g.to_algebra,
  exactI CommRing.of (A ⊗[R] B) }) := rfl

/-- Verify that the `pushout_cocone` is indeed the colimit. -/
def pushout_cocone_is_colimit : limits.is_colimit (pushout_cocone f g) :=
limits.pushout_cocone.is_colimit_aux' _ (λ s,
begin
  letI := ring_hom.to_algebra f,
  letI := ring_hom.to_algebra g,
  letI := ring_hom.to_algebra (f ≫ s.inl),
  let f' : A →ₐ[R] s.X := { commutes' := λ r, by
      { change s.inl.to_fun (f r) = (f ≫ s.inl) r, refl }, ..s.inl },
  let g' : B →ₐ[R] s.X := { commutes' := λ r, by
      { change (g ≫ s.inr) r = (f ≫ s.inl) r,
        congr' 1,
        exact (s.ι.naturality limits.walking_span.hom.snd).trans
          (s.ι.naturality limits.walking_span.hom.fst).symm }, ..s.inr },
  /- The factor map is a ⊗ b ↦ f(a) * g(b). -/
  use alg_hom.to_ring_hom (algebra.tensor_product.product_map f' g'),
  simp only [pushout_cocone_inl, pushout_cocone_inr],
  split, { ext x, exact algebra.tensor_product.product_map_left_apply  _ _ x, },
  split, { ext x, exact algebra.tensor_product.product_map_right_apply _ _ x, },
  intros h eq1 eq2,
  let h' : (A ⊗[R] B) →ₐ[R] s.X :=
    { commutes' := λ r, by
    { change h ((f r) ⊗ₜ[R] 1) = s.inl (f r),
      rw ← eq1, simp }, ..h },
  suffices : h' = algebra.tensor_product.product_map f' g',
  { ext x,
    change h' x = algebra.tensor_product.product_map f' g' x,
    rw this },
  apply algebra.tensor_product.ext,
  intros a b,
  simp [← eq1, ← eq2, ← h.map_mul],
end)

end pushout

section terminal

/-- The trivial ring is the (strict) terminal object of `CommRing`. -/
def punit_is_terminal : is_terminal (CommRing.of.{u} punit) :=
begin
  apply_with is_terminal.of_unique { instances := ff },
  tidy
end

instance CommRing_has_strict_terminal_objects : has_strict_terminal_objects CommRing.{u} :=
begin
  apply has_strict_terminal_objects_of_terminal_is_strict (CommRing.of punit),
  intros X f,
  refine ⟨⟨by tidy, by ext, _⟩⟩,
  ext,
  have e : (0 : X) = 1 := by { rw [← f.map_one, ← f.map_zero], congr },
  replace e : 0 * x = 1 * x := congr_arg (λ a, a * x) e,
  rw [one_mul, zero_mul, ← f.map_zero] at e,
  exact e,
end

lemma subsingleton_of_is_terminal {X : CommRing} (hX : is_terminal X) : subsingleton X :=
(hX.unique_up_to_iso punit_is_terminal).CommRing_iso_to_ring_equiv.to_equiv
  .subsingleton_congr.mpr (show subsingleton punit, by apply_instance)

/-- `ℤ` is the initial object of `CommRing`. -/
def Z_is_initial : is_initial (CommRing.of ℤ) :=
begin
  apply_with is_initial.of_unique { instances := ff },
  exact λ R, ⟨⟨int.cast_ring_hom R⟩, λ a, a.ext_int _⟩,
end

end terminal

section product

variables (A B : CommRing.{u})

/-- The product in `CommRing` is the cartesian product. This is the binary fan. -/
@[simps X]
def prod_fan : binary_fan A B :=
binary_fan.mk (CommRing.of_hom $ ring_hom.fst A B) (CommRing.of_hom $ ring_hom.snd A B)

/-- The product in `CommRing` is the cartesian product. -/
def prod_fan_is_limit : is_limit (prod_fan A B) :=
{ lift := λ c, ring_hom.prod (c.π.app walking_pair.left) (c.π.app walking_pair.right),
  fac' := λ c j, by { ext, cases j;
    simpa only [binary_fan.π_app_left, binary_fan.π_app_right, comp_apply, ring_hom.prod_apply] },
  uniq' := λ s m h, by { ext, { simpa using congr_hom (h walking_pair.left) x },
    { simpa using congr_hom (h walking_pair.right) x } } }

end product

section equalizer

variables {A B : CommRing.{u}} (f g : A ⟶ B)

/-- The equalizer in `CommRing` is the equalizer as sets. This is the equalizer fork. -/
def equalizer_fork : fork f g :=
fork.of_ι (CommRing.of_hom (ring_hom.eq_locus f g).subtype) (by { ext ⟨x, e⟩, simpa using e })

/-- The equalizer in `CommRing` is the equalizer as sets. -/
def equalizer_fork_is_limit : is_limit (equalizer_fork f g) :=
begin
  fapply fork.is_limit.mk',
  intro s,
  use s.ι.cod_restrict' _ (λ x, (concrete_category.congr_hom s.condition x : _)),
  split,
  { ext, refl },
  { intros m hm, ext x, exact concrete_category.congr_hom hm x }
end

instance : is_local_ring_hom (equalizer_fork f g).ι :=
begin
  constructor,
  rintros ⟨a, (h₁ : _ = _)⟩ (⟨⟨x,y,h₃,h₄⟩,(rfl : x = _)⟩ : is_unit a),
  have : y ∈ ring_hom.eq_locus f g,
  { apply (f.is_unit_map ⟨⟨x,y,h₃,h₄⟩,rfl⟩ : is_unit (f x)).mul_left_inj.mp,
    conv_rhs { rw h₁ },
    rw [← f.map_mul, ← g.map_mul, h₄, f.map_one, g.map_one] },
  rw is_unit_iff_exists_inv,
  exact ⟨⟨y, this⟩, subtype.eq h₃⟩,
end

instance equalizer_ι_is_local_ring_hom (F : walking_parallel_pair.{u} ⥤ CommRing.{u}) :
  is_local_ring_hom (limit.π F walking_parallel_pair.zero) :=
begin
  have := lim_map_π (diagram_iso_parallel_pair F).hom walking_parallel_pair.zero,
  rw ← is_iso.comp_inv_eq at this,
  rw ← this,
  rw ← limit.iso_limit_cone_hom_π ⟨_, equalizer_fork_is_limit
    (F.map walking_parallel_pair_hom.left) (F.map walking_parallel_pair_hom.right)⟩
    walking_parallel_pair.zero,
  change is_local_ring_hom ((lim.map _ ≫ _ ≫ (equalizer_fork _ _).ι) ≫ _),
  apply_instance
end

open category_theory.limits.walking_parallel_pair opposite
open category_theory.limits.walking_parallel_pair_hom

instance equalizer_ι_is_local_ring_hom' (F : walking_parallel_pair.{u}ᵒᵖ ⥤ CommRing.{u}) :
  is_local_ring_hom (limit.π F (opposite.op walking_parallel_pair.one)) :=
begin
  have : _ = limit.π F (walking_parallel_pair_op_equiv.{u u}.functor.obj _) :=
    (limit.iso_limit_cone_inv_π ⟨_, is_limit.whisker_equivalence (limit.is_limit F)
      walking_parallel_pair_op_equiv⟩ walking_parallel_pair.zero : _),
  erw ← this,
  apply_instance
end

end equalizer

end CommRing