/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Johannes Hölzl, Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.dfinsupp
import Mathlib.linear_algebra.basic
import Mathlib.PostPort

universes u_1 u_3 u_2 u_4

namespace Mathlib

/-!
# Properties of the semimodule `Π₀ i, M i`

Given an indexed collection of `R`-semimodules `M i`, the `R`-semimodule structure on `Π₀ i, M i`
is defined in `data.dfinsupp`.

In this file we define `linear_map` versions of various maps:

* `dfinsupp.lsingle a : M →ₗ[R] Π₀ i, M i`: `dfinsupp.single a` as a linear map;

* `dfinsupp.lmk s : (Π i : (↑s : set ι), M i) →ₗ[R] Π₀ i, M i`: `dfinsupp.single a` as a linear map;

* `dfinsupp.lapply i : (Π₀ i, M i) →ₗ[R] M`: the map `λ f, f i` as a linear map;

* `dfinsupp.lsum`: `dfinsupp.sum` or `dfinsupp.lift_add_hom` as a `linear_map`;

## Implementation notes

This file should try to mirror `linear_algebra.finsupp` where possible. The API of `finsupp` is
much more developed, but many lemmas in that file should be eligible to copy over.

## Tags

function with finite support, semimodule, linear algebra
-/

namespace dfinsupp

/-- `dfinsupp.mk` as a `linear_map`. -/
def lmk {ι : Type u_1} {R : Type u_2} {M : ι → Type u_3} [dec_ι : DecidableEq ι] [semiring R]
    [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (s : finset ι) :
    linear_map R ((i : ↥↑s) → M ↑i) (dfinsupp fun (i : ι) => M i) :=
  linear_map.mk (mk s) sorry sorry

/-- `dfinsupp.single` as a `linear_map` -/
def lsingle {ι : Type u_1} {R : Type u_2} {M : ι → Type u_3} [dec_ι : DecidableEq ι] [semiring R]
    [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (i : ι) :
    linear_map R (M i) (dfinsupp fun (i : ι) => M i) :=
  linear_map.mk (single i) sorry sorry

/-- Two `R`-linear maps from `Π₀ i, M i` which agree on each `single i x` agree everywhere. -/
theorem lhom_ext {ι : Type u_1} {R : Type u_2} {M : ι → Type u_3} {N : Type u_4}
    [dec_ι : DecidableEq ι] [semiring R] [(i : ι) → add_comm_monoid (M i)]
    [(i : ι) → semimodule R (M i)] [add_comm_monoid N] [semimodule R N]
    {φ : linear_map R (dfinsupp fun (i : ι) => M i) N}
    {ψ : linear_map R (dfinsupp fun (i : ι) => M i) N}
    (h : ∀ (i : ι) (x : M i), coe_fn φ (single i x) = coe_fn ψ (single i x)) : φ = ψ :=
  linear_map.to_add_monoid_hom_injective (add_hom_ext h)

/-- Two `R`-linear maps from `Π₀ i, M i` which agree on each `single i x` agree everywhere.

See note [partially-applied ext lemmas].
After apply this lemma, if `M = R` then it suffices to verify `φ (single a 1) = ψ (single a 1)`. -/
theorem lhom_ext' {ι : Type u_1} {R : Type u_2} {M : ι → Type u_3} {N : Type u_4}
    [dec_ι : DecidableEq ι] [semiring R] [(i : ι) → add_comm_monoid (M i)]
    [(i : ι) → semimodule R (M i)] [add_comm_monoid N] [semimodule R N]
    {φ : linear_map R (dfinsupp fun (i : ι) => M i) N}
    {ψ : linear_map R (dfinsupp fun (i : ι) => M i) N}
    (h : ∀ (i : ι), linear_map.comp φ (lsingle i) = linear_map.comp ψ (lsingle i)) : φ = ψ :=
  lhom_ext fun (i : ι) => linear_map.congr_fun (h i)

/-- Interpret `λ (f : Π₀ i, M i), f i` as a linear map. -/
def lapply {ι : Type u_1} {R : Type u_2} {M : ι → Type u_3} [semiring R]
    [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (i : ι) :
    linear_map R (dfinsupp fun (i : ι) => M i) (M i) :=
  linear_map.mk (fun (f : dfinsupp fun (i : ι) => M i) => coe_fn f i) sorry sorry

@[simp] theorem lmk_apply {ι : Type u_1} {R : Type u_2} {M : ι → Type u_3} [dec_ι : DecidableEq ι]
    [semiring R] [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (s : finset ι)
    (x : (i : ↥↑s) → (fun (i : ι) => M i) ↑i) : coe_fn (lmk s) x = mk s x :=
  rfl

@[simp] theorem lsingle_apply {ι : Type u_1} {R : Type u_2} {M : ι → Type u_3}
    [dec_ι : DecidableEq ι] [semiring R] [(i : ι) → add_comm_monoid (M i)]
    [(i : ι) → semimodule R (M i)] (i : ι) (x : M i) : coe_fn (lsingle i) x = single i x :=
  rfl

@[simp] theorem lapply_apply {ι : Type u_1} {R : Type u_2} {M : ι → Type u_3} [semiring R]
    [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (i : ι)
    (f : dfinsupp fun (i : ι) => M i) : coe_fn (lapply i) f = coe_fn f i :=
  rfl

/-- The `dfinsupp` version of `finsupp.lsum`. -/
def lsum {ι : Type u_1} {R : Type u_2} {M : ι → Type u_3} {N : Type u_4} [dec_ι : DecidableEq ι]
    [semiring R] [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)]
    [add_comm_monoid N] [semimodule R N] :
    ((i : ι) → linear_map R (M i) N) ≃+ linear_map R (dfinsupp fun (i : ι) => M i) N :=
  add_equiv.mk
    (fun (F : (i : ι) → linear_map R (M i) N) =>
      linear_map.mk ⇑(sum_add_hom fun (i : ι) => linear_map.to_add_monoid_hom (F i)) sorry sorry)
    (fun (F : linear_map R (dfinsupp fun (i : ι) => M i) N) (i : ι) =>
      linear_map.comp F (lsingle i))
    sorry sorry sorry

end Mathlib


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.limits.has_limits
import category_theory.products.basic
import category_theory.currying

/-!
# A Fubini theorem for categorical limits

We prove that $lim_{J × K} G = lim_J (lim_K G(j, -))$ for a functor `G : J × K ⥤ C`,
when all the appropriate limits exist.

We begin working with a functor `F : J ⥤ K ⥤ C`. We'll write `G : J × K ⥤ C` for the associated
"uncurried" functor.

In the first part, given a coherent family `D` of limit cones over the functors `F.obj j`,
and a cone `c` over `G`, we construct a cone over the cone points of `D`.
We then show that if `c` is a limit cone, the constructed cone is also a limit cone.

In the second part, we state the Fubini theorem in the setting where limits are
provided by suitable `has_limit` classes.

We construct
`limit_uncurry_iso_limit_comp_lim F : limit (uncurry.obj F) ≅ limit (F ⋙ lim)`
and give simp lemmas characterising it.
For convenience, we also provide
`limit_iso_limit_curry_comp_lim G : limit G ≅ limit ((curry.obj G) ⋙ lim)`
in terms of the uncurried functor.

## Future work

The dual statement.
-/

universes v u

open category_theory

namespace category_theory.limits

variables {J K : Type v} [small_category J] [small_category K]
variables {C : Type u} [category.{v} C]

variables (F : J ⥤ K ⥤ C)

/--
A structure carrying a diagram of cones over the the functors `F.obj j`.
-/
-- We could try introducing a "dependent functor type" to handle this?
structure diagram_of_cones :=
(obj : Π j : J, cone (F.obj j))
(map : Π {j j' : J} (f : j ⟶ j'), (cones.postcompose (F.map f)).obj (obj j) ⟶ obj j')
(id : ∀ j : J, (map (𝟙 j)).hom = 𝟙 _ . obviously)
(comp : ∀ {j₁ j₂ j₃ : J} (f : j₁ ⟶ j₂) (g : j₂ ⟶ j₃),
  (map (f ≫ g)).hom = (map f).hom ≫ (map g).hom . obviously)

variables {F}

/--
Extract the functor `J ⥤ C` consisting of the cone points and the maps between them,
from a `diagram_of_cones`.
-/
@[simps]
def diagram_of_cones.cone_points (D : diagram_of_cones F) :
  J ⥤ C :=
{ obj := λ j, (D.obj j).X,
  map := λ j j' f, (D.map f).hom,
  map_id' := λ j, D.id j,
  map_comp' := λ j₁ j₂ j₃ f g, D.comp f g, }

/--
Given a diagram `D` of limit cones over the `F.obj j`, and a cone over `uncurry.obj F`,
we can construct a cone over the diagram consisting of the cone points from `D`.
-/
@[simps]
def cone_of_cone_uncurry
  {D : diagram_of_cones F} (Q : Π j, is_limit (D.obj j))
  (c : cone (uncurry.obj F)) :
  cone (D.cone_points) :=
{ X := c.X,
  π :=
  { app := λ j, (Q j).lift
    { X := c.X,
      π :=
      { app := λ k, c.π.app (j, k),
        naturality' := λ k k' f,
        begin
          dsimp, simp only [category.id_comp],
          have := @nat_trans.naturality _ _ _ _ _ _ c.π (j, k) (j, k') (𝟙 j, f),
          dsimp at this,
          simp only [category.id_comp, category_theory.functor.map_id, nat_trans.id_app] at this,
          exact this,
        end } },
    naturality' := λ j j' f, (Q j').hom_ext
    begin
      dsimp,
      intro k,
      simp only [limits.cone_morphism.w, limits.cones.postcompose_obj_π, limits.is_limit.fac_assoc,
        limits.is_limit.fac, nat_trans.comp_app, category.id_comp, category.assoc],
      have := @nat_trans.naturality _ _ _ _ _ _ c.π (j, k) (j', k) (f, 𝟙 k),
      dsimp at this,
      simp only [category.id_comp, category.comp_id,
        category_theory.functor.map_id, nat_trans.id_app] at this,
      exact this,
    end, } }.

/--
`cone_of_cone_uncurry Q c` is a limit cone when `c` is a limit cone.`
-/
def cone_of_cone_uncurry_is_limit
  {D : diagram_of_cones F} (Q : Π j, is_limit (D.obj j))
  {c : cone (uncurry.obj F)} (P : is_limit c) :
  is_limit (cone_of_cone_uncurry Q c) :=
{ lift := λ s, P.lift
  { X := s.X,
    π :=
    { app := λ p, s.π.app p.1 ≫ (D.obj p.1).π.app p.2,
      naturality' := λ p p' f,
      begin
        dsimp, simp only [category.id_comp, category.assoc],
        rcases p with ⟨j, k⟩,
        rcases p' with ⟨j', k'⟩,
        rcases f with ⟨fj, fk⟩,
        dsimp,
        slice_rhs 3 4 { rw ←nat_trans.naturality, },
        slice_rhs 2 3 { rw ←(D.obj j).π.naturality, },
        simp only [functor.const.obj_map, category.id_comp, category.assoc],
        have w := (D.map fj).w k',
        dsimp at w,
        rw ←w,
        have n := s.π.naturality fj,
        dsimp at n,
        simp only [category.id_comp] at n,
        rw n,
        simp,
      end, } },
  fac' := λ s j,
  begin
    apply (Q j).hom_ext,
    intro k,
    simp,
  end,
  uniq' := λ s m w,
  begin
    refine P.uniq { X := s.X, π := _, } m _,
    rintro ⟨j, k⟩,
    dsimp,
    rw [←w j],
    simp,
  end, }

section
variables (F)
variables [has_limits_of_shape K C]

/--
Given a functor `F : J ⥤ K ⥤ C`, with all needed limits,
we can construct a diagram consisting of the limit cone over each functor `F.obj j`,
and the universal cone morphisms between these.
-/
@[simps]
noncomputable def diagram_of_cones.mk_of_has_limits : diagram_of_cones F :=
{ obj := λ j, limit.cone (F.obj j),
  map := λ j j' f, { hom := lim.map (F.map f), }, }

-- Satisfying the inhabited linter.
noncomputable instance diagram_of_cones_inhabited : inhabited (diagram_of_cones F) :=
⟨diagram_of_cones.mk_of_has_limits F⟩

@[simp]
lemma diagram_of_cones.mk_of_has_limits_cone_points :
  (diagram_of_cones.mk_of_has_limits F).cone_points = (F ⋙ lim) :=
rfl

variables [has_limit (uncurry.obj F)]
variables [has_limit (F ⋙ lim)]

/--
The Fubini theorem for a functor `F : J ⥤ K ⥤ C`,
showing that the limit of `uncurry.obj F` can be computed as
the limit of the limits of the functors `F.obj j`.
-/
noncomputable def limit_uncurry_iso_limit_comp_lim : limit (uncurry.obj F) ≅ limit (F ⋙ lim) :=
begin
  let c := limit.cone (uncurry.obj F),
  let P : is_limit c := limit.is_limit _,
  let G := diagram_of_cones.mk_of_has_limits F,
  let Q : Π j, is_limit (G.obj j) := λ j, limit.is_limit _,
  have Q' := cone_of_cone_uncurry_is_limit Q P,
  have Q'' := (limit.is_limit (F ⋙ lim)),
  exact is_limit.cone_point_unique_up_to_iso Q' Q'',
end

@[simp]
lemma limit_uncurry_iso_limit_comp_lim_hom_π_π {j} {k} :
  (limit_uncurry_iso_limit_comp_lim F).hom ≫ limit.π _ j ≫ limit.π _ k = limit.π _ (j, k) :=
begin
  dsimp [limit_uncurry_iso_limit_comp_lim, is_limit.cone_point_unique_up_to_iso,
    is_limit.unique_up_to_iso],
  simp,
end

@[simp]
lemma limit_uncurry_iso_limit_comp_lim_inv_π {j} {k} :
  (limit_uncurry_iso_limit_comp_lim F).inv ≫ limit.π _ (j, k) = limit.π _ j ≫ limit.π _ k :=
begin
  rw [←cancel_epi (limit_uncurry_iso_limit_comp_lim F).hom],
  simp,
end
end

section
variables (G : J × K ⥤ C)

section
variables [has_limits_of_shape K C]
variables [has_limit G]
variables [has_limit ((curry.obj G) ⋙ lim)]

/--
The Fubini theorem for a functor `G : J × K ⥤ C`,
showing that the limit of `G` can be computed as
the limit of the limits of the functors `G.obj (j, _)`.
-/
noncomputable def limit_iso_limit_curry_comp_lim : limit G ≅ limit ((curry.obj G) ⋙ lim) :=
begin
  have i : G ≅ uncurry.obj ((@curry J _ K _ C _).obj G) := currying.symm.unit_iso.app G,
  haveI : limits.has_limit (uncurry.obj ((@curry J _ K _ C _).obj G)) :=
    has_limit_of_iso i,
  transitivity limit (uncurry.obj ((@curry J _ K _ C _).obj G)),
  apply has_limit.iso_of_nat_iso i,
  exact limit_uncurry_iso_limit_comp_lim ((@curry J _ K _ C _).obj G),
end

@[simp, reassoc]
lemma limit_iso_limit_curry_comp_lim_hom_π_π {j} {k} :
  (limit_iso_limit_curry_comp_lim G).hom ≫ limit.π _ j ≫ limit.π _ k = limit.π _ (j, k) :=
by simp [limit_iso_limit_curry_comp_lim, is_limit.cone_point_unique_up_to_iso,
  is_limit.unique_up_to_iso]

@[simp, reassoc]
lemma limit_iso_limit_curry_comp_lim_inv_π {j} {k} :
  (limit_iso_limit_curry_comp_lim G).inv ≫ limit.π _ (j, k) = limit.π _ j ≫ limit.π _ k :=
begin
  rw [←cancel_epi (limit_iso_limit_curry_comp_lim G).hom],
  simp,
end
end

section
variables [has_limits C] -- Certainly one could weaken the hypotheses here.

open category_theory.prod

/--
A variant of the Fubini theorem for a functor `G : J × K ⥤ C`,
showing that $\lim_k \lim_j G(j,k) ≅ \lim_j \lim_k G(j,k)$.
-/
noncomputable
def limit_curry_swap_comp_lim_iso_limit_curry_comp_lim :
  limit ((curry.obj (swap K J ⋙ G)) ⋙ lim) ≅ limit ((curry.obj G) ⋙ lim) :=
calc
  limit ((curry.obj (swap K J ⋙ G)) ⋙ lim)
      ≅ limit (swap K J ⋙ G) : (limit_iso_limit_curry_comp_lim _).symm
  ... ≅ limit G : has_limit.iso_of_equivalence (braiding K J) (iso.refl _)
  ... ≅ limit ((curry.obj G) ⋙ lim) : limit_iso_limit_curry_comp_lim _

@[simp]
lemma limit_curry_swap_comp_lim_iso_limit_curry_comp_lim_hom_π_π {j} {k} :
  (limit_curry_swap_comp_lim_iso_limit_curry_comp_lim G).hom ≫ limit.π _ j ≫ limit.π _ k =
   limit.π _ k ≫ limit.π _ j :=
begin
  dsimp [limit_curry_swap_comp_lim_iso_limit_curry_comp_lim],
  simp only [iso.refl_hom, braiding_counit_iso_hom_app, limits.has_limit.iso_of_equivalence_hom_π,
    iso.refl_inv, limit_iso_limit_curry_comp_lim_hom_π_π, eq_to_iso_refl, category.assoc],
  erw [nat_trans.id_app], -- Why can't `simp` do this`?
  dsimp, simp,
end

@[simp]
lemma limit_curry_swap_comp_lim_iso_limit_curry_comp_lim_inv_π_π {j} {k} :
  (limit_curry_swap_comp_lim_iso_limit_curry_comp_lim G).inv ≫ limit.π _ k ≫ limit.π _ j =
   limit.π _ j ≫ limit.π _ k :=
begin
  dsimp [limit_curry_swap_comp_lim_iso_limit_curry_comp_lim],
  simp only [iso.refl_hom, braiding_counit_iso_hom_app, limits.has_limit.iso_of_equivalence_inv_π,
    iso.refl_inv, limit_iso_limit_curry_comp_lim_hom_π_π, eq_to_iso_refl, category.assoc],
  erw [nat_trans.id_app], -- Why can't `simp` do this`?
  dsimp, simp,
end

end

end

end category_theory.limits


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.multiset.powerset
import Mathlib.data.multiset.range
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

/-!
# The `nodup` predicate for multisets without duplicate elements.
-/

namespace multiset

/- nodup -/

/-- `nodup s` means that `s` has no duplicates, i.e. the multiplicity of
  any element is at most 1. -/
def nodup {α : Type u_1} (s : multiset α) := quot.lift_on s list.nodup sorry

@[simp] theorem coe_nodup {α : Type u_1} {l : List α} : nodup ↑l ↔ list.nodup l := iff.rfl

@[simp] theorem nodup_zero {α : Type u_1} : nodup 0 := list.pairwise.nil

@[simp] theorem nodup_cons {α : Type u_1} {a : α} {s : multiset α} :
    nodup (a ::ₘ s) ↔ ¬a ∈ s ∧ nodup s :=
  quot.induction_on s fun (l : List α) => list.nodup_cons

theorem nodup_cons_of_nodup {α : Type u_1} {a : α} {s : multiset α} (m : ¬a ∈ s) (n : nodup s) :
    nodup (a ::ₘ s) :=
  iff.mpr nodup_cons { left := m, right := n }

theorem nodup_singleton {α : Type u_1} (a : α) : nodup (a ::ₘ 0) := list.nodup_singleton

theorem nodup_of_nodup_cons {α : Type u_1} {a : α} {s : multiset α} (h : nodup (a ::ₘ s)) :
    nodup s :=
  and.right (iff.mp nodup_cons h)

theorem not_mem_of_nodup_cons {α : Type u_1} {a : α} {s : multiset α} (h : nodup (a ::ₘ s)) :
    ¬a ∈ s :=
  and.left (iff.mp nodup_cons h)

theorem nodup_of_le {α : Type u_1} {s : multiset α} {t : multiset α} (h : s ≤ t) :
    nodup t → nodup s :=
  le_induction_on h fun (l₁ l₂ : List α) => list.nodup_of_sublist

theorem not_nodup_pair {α : Type u_1} (a : α) : ¬nodup (a ::ₘ a ::ₘ 0) := list.not_nodup_pair

theorem nodup_iff_le {α : Type u_1} {s : multiset α} : nodup s ↔ ∀ (a : α), ¬a ::ₘ a ::ₘ 0 ≤ s :=
  quot.induction_on s
    fun (l : List α) =>
      iff.trans list.nodup_iff_sublist
        (forall_congr fun (a : α) => not_congr (iff.symm repeat_le_coe))

theorem nodup_iff_ne_cons_cons {α : Type u_1} {s : multiset α} :
    nodup s ↔ ∀ (a : α) (t : multiset α), s ≠ a ::ₘ a ::ₘ t :=
  sorry

theorem nodup_iff_count_le_one {α : Type u_1} [DecidableEq α] {s : multiset α} :
    nodup s ↔ ∀ (a : α), count a s ≤ 1 :=
  quot.induction_on s fun (l : List α) => list.nodup_iff_count_le_one

@[simp] theorem count_eq_one_of_mem {α : Type u_1} [DecidableEq α] {a : α} {s : multiset α}
    (d : nodup s) (h : a ∈ s) : count a s = 1 :=
  le_antisymm (iff.mp nodup_iff_count_le_one d a) (iff.mpr count_pos h)

theorem nodup_iff_pairwise {α : Type u_1} {s : multiset α} : nodup s ↔ pairwise ne s :=
  quotient.induction_on s
    fun (l : List α) => iff.symm (pairwise_coe_iff_pairwise fun (a b : α) => ne.symm)

theorem pairwise_of_nodup {α : Type u_1} {r : α → α → Prop} {s : multiset α} :
    (∀ (a : α), a ∈ s → ∀ (b : α), b ∈ s → a ≠ b → r a b) → nodup s → pairwise r s :=
  sorry

theorem forall_of_pairwise {α : Type u_1} {r : α → α → Prop} (H : symmetric r) {s : multiset α}
    (hs : pairwise r s) (a : α) : a ∈ s → ∀ (b : α), b ∈ s → a ≠ b → r a b :=
  sorry

theorem nodup_add {α : Type u_1} {s : multiset α} {t : multiset α} :
    nodup (s + t) ↔ nodup s ∧ nodup t ∧ disjoint s t :=
  quotient.induction_on₂ s t fun (l₁ l₂ : List α) => list.nodup_append

theorem disjoint_of_nodup_add {α : Type u_1} {s : multiset α} {t : multiset α} (d : nodup (s + t)) :
    disjoint s t :=
  and.right (and.right (iff.mp nodup_add d))

theorem nodup_add_of_nodup {α : Type u_1} {s : multiset α} {t : multiset α} (d₁ : nodup s)
    (d₂ : nodup t) : nodup (s + t) ↔ disjoint s t :=
  sorry

theorem nodup_of_nodup_map {α : Type u_1} {β : Type u_2} (f : α → β) {s : multiset α} :
    nodup (map f s) → nodup s :=
  quot.induction_on s fun (l : List α) => list.nodup_of_nodup_map f

theorem nodup_map_on {α : Type u_1} {β : Type u_2} {f : α → β} {s : multiset α} :
    (∀ (x : α), x ∈ s → ∀ (y : α), y ∈ s → f x = f y → x = y) → nodup s → nodup (map f s) :=
  quot.induction_on s fun (l : List α) => list.nodup_map_on

theorem nodup_map {α : Type u_1} {β : Type u_2} {f : α → β} {s : multiset α}
    (hf : function.injective f) : nodup s → nodup (map f s) :=
  nodup_map_on fun (x : α) (_x : x ∈ s) (y : α) (_x : y ∈ s) (h : f x = f y) => hf h

theorem nodup_filter {α : Type u_1} (p : α → Prop) [decidable_pred p] {s : multiset α} :
    nodup s → nodup (filter p s) :=
  quot.induction_on s fun (l : List α) => list.nodup_filter p

@[simp] theorem nodup_attach {α : Type u_1} {s : multiset α} : nodup (attach s) ↔ nodup s :=
  quot.induction_on s fun (l : List α) => list.nodup_attach

theorem nodup_pmap {α : Type u_1} {β : Type u_2} {p : α → Prop} {f : (a : α) → p a → β}
    {s : multiset α} {H : ∀ (a : α), a ∈ s → p a}
    (hf : ∀ (a : α) (ha : p a) (b : α) (hb : p b), f a ha = f b hb → a = b) :
    nodup s → nodup (pmap f s H) :=
  quot.induction_on s
    (fun (l : List α) (H : ∀ (a : α), a ∈ Quot.mk setoid.r l → p a) => list.nodup_pmap hf) H

protected instance nodup_decidable {α : Type u_1} [DecidableEq α] (s : multiset α) :
    Decidable (nodup s) :=
  quotient.rec_on_subsingleton s fun (l : List α) => list.nodup_decidable l

theorem nodup_erase_eq_filter {α : Type u_1} [DecidableEq α] (a : α) {s : multiset α} :
    nodup s → erase s a = filter (fun (_x : α) => _x ≠ a) s :=
  quot.induction_on s
    fun (l : List α) (d : nodup (Quot.mk setoid.r l)) =>
      congr_arg coe (list.nodup_erase_eq_filter a d)

theorem nodup_erase_of_nodup {α : Type u_1} [DecidableEq α] (a : α) {l : multiset α} :
    nodup l → nodup (erase l a) :=
  nodup_of_le (erase_le a l)

theorem mem_erase_iff_of_nodup {α : Type u_1} [DecidableEq α] {a : α} {b : α} {l : multiset α}
    (d : nodup l) : a ∈ erase l b ↔ a ≠ b ∧ a ∈ l :=
  sorry

theorem mem_erase_of_nodup {α : Type u_1} [DecidableEq α] {a : α} {l : multiset α} (h : nodup l) :
    ¬a ∈ erase l a :=
  sorry

theorem nodup_product {α : Type u_1} {β : Type u_2} {s : multiset α} {t : multiset β} :
    nodup s → nodup t → nodup (product s t) :=
  sorry

theorem nodup_sigma {α : Type u_1} {σ : α → Type u_2} {s : multiset α}
    {t : (a : α) → multiset (σ a)} :
    nodup s → (∀ (a : α), nodup (t a)) → nodup (multiset.sigma s t) :=
  sorry

theorem nodup_filter_map {α : Type u_1} {β : Type u_2} (f : α → Option β) {s : multiset α}
    (H : ∀ (a a' : α) (b : β), b ∈ f a → b ∈ f a' → a = a') : nodup s → nodup (filter_map f s) :=
  quot.induction_on s fun (l : List α) => list.nodup_filter_map H

theorem nodup_range (n : ℕ) : nodup (range n) := list.nodup_range n

theorem nodup_inter_left {α : Type u_1} [DecidableEq α] {s : multiset α} (t : multiset α) :
    nodup s → nodup (s ∩ t) :=
  nodup_of_le (inter_le_left s t)

theorem nodup_inter_right {α : Type u_1} [DecidableEq α] (s : multiset α) {t : multiset α} :
    nodup t → nodup (s ∩ t) :=
  nodup_of_le (inter_le_right s t)

@[simp] theorem nodup_union {α : Type u_1} [DecidableEq α] {s : multiset α} {t : multiset α} :
    nodup (s ∪ t) ↔ nodup s ∧ nodup t :=
  sorry

@[simp] theorem nodup_powerset {α : Type u_1} {s : multiset α} : nodup (powerset s) ↔ nodup s :=
  sorry

theorem nodup_powerset_len {α : Type u_1} {n : ℕ} {s : multiset α} (h : nodup s) :
    nodup (powerset_len n s) :=
  nodup_of_le (powerset_len_le_powerset n s) (iff.mpr nodup_powerset h)

@[simp] theorem nodup_bind {α : Type u_1} {β : Type u_2} {s : multiset α} {t : α → multiset β} :
    nodup (bind s t) ↔
        (∀ (a : α), a ∈ s → nodup (t a)) ∧ pairwise (fun (a b : α) => disjoint (t a) (t b)) s :=
  sorry

theorem nodup_ext {α : Type u_1} {s : multiset α} {t : multiset α} :
    nodup s → nodup t → (s = t ↔ ∀ (a : α), a ∈ s ↔ a ∈ t) :=
  quotient.induction_on₂ s t
    fun (l₁ l₂ : List α) (d₁ : nodup (quotient.mk l₁)) (d₂ : nodup (quotient.mk l₂)) =>
      iff.trans quotient.eq (list.perm_ext d₁ d₂)

theorem le_iff_subset {α : Type u_1} {s : multiset α} {t : multiset α} :
    nodup s → (s ≤ t ↔ s ⊆ t) :=
  quotient.induction_on₂ s t
    fun (l₁ l₂ : List α) (d : nodup (quotient.mk l₁)) =>
      { mp := subset_of_le, mpr := list.subperm_of_subset_nodup d }

theorem range_le {m : ℕ} {n : ℕ} : range m ≤ range n ↔ m ≤ n :=
  iff.trans (le_iff_subset (nodup_range m)) range_subset

theorem mem_sub_of_nodup {α : Type u_1} [DecidableEq α] {a : α} {s : multiset α} {t : multiset α}
    (d : nodup s) : a ∈ s - t ↔ a ∈ s ∧ ¬a ∈ t :=
  sorry

theorem map_eq_map_of_bij_of_nodup {α : Type u_1} {β : Type u_2} {γ : Type u_3} (f : α → γ)
    (g : β → γ) {s : multiset α} {t : multiset β} (hs : nodup s) (ht : nodup t)
    (i : (a : α) → a ∈ s → β) (hi : ∀ (a : α) (ha : a ∈ s), i a ha ∈ t)
    (h : ∀ (a : α) (ha : a ∈ s), f a = g (i a ha))
    (i_inj : ∀ (a₁ a₂ : α) (ha₁ : a₁ ∈ s) (ha₂ : a₂ ∈ s), i a₁ ha₁ = i a₂ ha₂ → a₁ = a₂)
    (i_surj : ∀ (b : β), b ∈ t → ∃ (a : α), ∃ (ha : a ∈ s), b = i a ha) : map f s = map g t :=
  sorry

end Mathlib


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import category_theory.limits.preserves.shapes.binary_products
import category_theory.limits.preserves.shapes.terminal
import category_theory.adjunction.fully_faithful

/-!
# Reflective functors

Basic properties of reflective functors, especially those relating to their essential image.

Note properties of reflective functors relating to limits and colimits are included in
`category_theory.monad.limits`.
-/

universes v₁ v₂ v₃ u₁ u₂ u₃

noncomputable theory

namespace category_theory

open category adjunction limits

variables {C : Type u₁} {D : Type u₂} {E : Type u₃}
variables [category.{v₁} C] [category.{v₂} D] [category.{v₃} E]

/--
A functor is *reflective*, or *a reflective inclusion*, if it is fully faithful and right adjoint.
-/
class reflective (R : D ⥤ C) extends is_right_adjoint R, full R, faithful R.

variables {i : D ⥤ C}

/--
For a reflective functor `i` (with left adjoint `L`), with unit `η`, we have `η_iL = iL η`.
-/
-- TODO: This holds more generally for idempotent adjunctions, not just reflective adjunctions.
lemma unit_obj_eq_map_unit [reflective i] (X : C) :
  (of_right_adjoint i).unit.app (i.obj ((left_adjoint i).obj X))
    = i.map ((left_adjoint i).map ((of_right_adjoint i).unit.app X)) :=
begin
 rw [←cancel_mono (i.map ((of_right_adjoint i).counit.app ((left_adjoint i).obj X))),
     ←i.map_comp],
 simp,
end

/--
When restricted to objects in `D` given by `i : D ⥤ C`, the unit is an isomorphism. In other words,
`η_iX` is an isomorphism for any `X` in `D`.
More generally this applies to objects essentially in the reflective subcategory, see
`functor.ess_image.unit_iso`.
-/
instance is_iso_unit_obj [reflective i] {B : D} :
  is_iso ((of_right_adjoint i).unit.app (i.obj B)) :=
begin
  have : (of_right_adjoint i).unit.app (i.obj B) =
            inv (i.map ((of_right_adjoint i).counit.app B)),
  { rw ← comp_hom_eq_id,
    apply (of_right_adjoint i).right_triangle_components },
  rw this,
  exact is_iso.inv_is_iso,
end

/--
If `A` is essentially in the image of a reflective functor `i`, then `η_A` is an isomorphism.
This gives that the "witness" for `A` being in the essential image can instead be given as the
reflection of `A`, with the isomorphism as `η_A`.

(For any `B` in the reflective subcategory, we automatically have that `ε_B` is an iso.)
-/
lemma functor.ess_image.unit_is_iso [reflective i] {A : C} (h : A ∈ i.ess_image) :
  is_iso ((of_right_adjoint i).unit.app A) :=
begin
  suffices : (of_right_adjoint i).unit.app A =
                h.get_iso.inv ≫ (of_right_adjoint i).unit.app (i.obj h.witness) ≫
                  (left_adjoint i ⋙ i).map h.get_iso.hom,
  { rw this,
    apply_instance },
  rw ← nat_trans.naturality,
  simp,
end

/-- If `η_A` is an isomorphism, then `A` is in the essential image of `i`. -/
lemma mem_ess_image_of_unit_is_iso [is_right_adjoint i] (A : C)
  [is_iso ((of_right_adjoint i).unit.app A)] : A ∈ i.ess_image :=
⟨(left_adjoint i).obj A, ⟨(as_iso ((of_right_adjoint i).unit.app A)).symm⟩⟩

/-- If `η_A` is a split monomorphism, then `A` is in the reflective subcategory. -/
lemma mem_ess_image_of_unit_split_mono [reflective i] {A : C}
  [split_mono ((of_right_adjoint i).unit.app A)] : A ∈ i.ess_image :=
begin
  let η : 𝟭 C ⟶ left_adjoint i ⋙ i := (of_right_adjoint i).unit,
  haveI : is_iso (η.app (i.obj ((left_adjoint i).obj A))) := (i.obj_mem_ess_image _).unit_is_iso,
  have : epi (η.app A),
  { apply epi_of_epi (retraction (η.app A)) _,
    rw (show retraction _ ≫ η.app A = _, from η.naturality (retraction (η.app A))),
    apply epi_comp (η.app (i.obj ((left_adjoint i).obj A))) },
  resetI,
  haveI := is_iso_of_epi_of_split_mono (η.app A),
  exact mem_ess_image_of_unit_is_iso A,
end

/-- Composition of reflective functors. -/
instance reflective.comp (F : C ⥤ D) (G : D ⥤ E) [Fr : reflective F] [Gr : reflective G] :
  reflective (F ⋙ G) := { to_faithful := faithful.comp F G, }

/-- (Implementation) Auxiliary definition for `unit_comp_partial_bijective`. -/
def unit_comp_partial_bijective_aux [reflective i] (A : C) (B : D) :
  (A ⟶ i.obj B) ≃ (i.obj ((left_adjoint i).obj A) ⟶ i.obj B) :=
((adjunction.of_right_adjoint i).hom_equiv _ _).symm.trans (equiv_of_fully_faithful i)

/-- The description of the inverse of the bijection `unit_comp_partial_bijective_aux`. -/
lemma unit_comp_partial_bijective_aux_symm_apply [reflective i] {A : C} {B : D}
  (f : i.obj ((left_adjoint i).obj A) ⟶ i.obj B) :
  (unit_comp_partial_bijective_aux _ _).symm f = (of_right_adjoint i).unit.app A ≫ f :=
by simp [unit_comp_partial_bijective_aux]

/--
If `i` has a reflector `L`, then the function `(i.obj (L.obj A) ⟶ B) → (A ⟶ B)` given by
precomposing with `η.app A` is a bijection provided `B` is in the essential image of `i`.
That is, the function `λ (f : i.obj (L.obj A) ⟶ B), η.app A ≫ f` is bijective, as long as `B` is in
the essential image of `i`.
This definition gives an equivalence: the key property that the inverse can be described
nicely is shown in `unit_comp_partial_bijective_symm_apply`.

This establishes there is a natural bijection `(A ⟶ B) ≃ (i.obj (L.obj A) ⟶ B)`. In other words,
from the point of view of objects in `D`, `A` and `i.obj (L.obj A)` look the same: specifically
that `η.app A` is an isomorphism.
-/
def unit_comp_partial_bijective [reflective i] (A : C) {B : C} (hB : B ∈ i.ess_image) :
  (A ⟶ B) ≃ (i.obj ((left_adjoint i).obj A) ⟶ B) :=
calc (A ⟶ B) ≃ (A ⟶ i.obj hB.witness) : iso.hom_congr (iso.refl _) hB.get_iso.symm
     ...     ≃ (i.obj _ ⟶ i.obj hB.witness) : unit_comp_partial_bijective_aux _ _
     ...     ≃ (i.obj ((left_adjoint i).obj A) ⟶ B) : iso.hom_congr (iso.refl _) hB.get_iso

@[simp]
lemma unit_comp_partial_bijective_symm_apply [reflective i] (A : C) {B : C}
  (hB : B ∈ i.ess_image) (f) :
  (unit_comp_partial_bijective A hB).symm f = (of_right_adjoint i).unit.app A ≫ f :=
by simp [unit_comp_partial_bijective, unit_comp_partial_bijective_aux_symm_apply]

lemma unit_comp_partial_bijective_symm_natural [reflective i] (A : C) {B B' : C} (h : B ⟶ B')
  (hB : B ∈ i.ess_image) (hB' : B' ∈ i.ess_image) (f : i.obj ((left_adjoint i).obj A) ⟶ B) :
  (unit_comp_partial_bijective A hB').symm (f ≫ h) =
    (unit_comp_partial_bijective A hB).symm f ≫ h :=
by simp

lemma unit_comp_partial_bijective_natural [reflective i] (A : C) {B B' : C} (h : B ⟶ B')
  (hB : B ∈ i.ess_image) (hB' : B' ∈ i.ess_image) (f : A ⟶ B) :
  (unit_comp_partial_bijective A hB') (f ≫ h) = unit_comp_partial_bijective A hB f ≫ h :=
by rw [←equiv.eq_symm_apply, unit_comp_partial_bijective_symm_natural A h, equiv.symm_apply_apply]

end category_theory


structure BundledFunction (α β : Sort _) :=
(toFun : α → β)

namespace BundledFunction

-- `simp` doesn't seem to unify partial applications of structure projections:
-- https://leanprover.zulipchat.com/#narrow/stream/287929-mathlib4/topic/.60simp.60.20failing.20on.20partial.20application.20of.20projections
def id (α) : BundledFunction α α := ⟨λ a => a⟩

@[simp] theorem coe_id : (id α).toFun = _root_.id := rfl

example (x : α) : (id α).toFun x = x :=
by simp only [coe_id, id_eq] -- should succeed
example (x : α) : (id α).toFun x = x :=
by rw [coe_id, id_eq] -- succeeds

-- seems to be another instance of the same behaviour:
-- https://leanprover.zulipchat.com/#narrow/stream/287929-mathlib4/topic/.60simp.60.20calls.20broken.20in.20mathlib4.23922/near/314790371

def otherProjection (f : BundledFunction α β) : α → β := f.toFun

-- Projections functions are expanded when populating the discrimination tree, and are indexed as `Expr.proj` objects.
-- `@toFun α β` cannot be expanded into `Expr.proj` since there is a missing argument. The workaround is to add the missing argument.
-- Then, we get `a.1 = otherProjection a`
@[simp] theorem toFun_eq_otherProjection : @toFun α β a = otherProjection a := rfl
@[simp] theorem id_apply : (id α).otherProjection x = x := rfl

example : (id α).toFun x = x := by simp only [toFun_eq_otherProjection, id_apply]; done -- should work
example : (id α).toFun x = x := by rw [toFun_eq_otherProjection, id_apply] -- succeeds

end BundledFunction

-- `simp` is happy with partial applications in other functions:
def id2 (x : α) := x

@[simp] theorem id2_eq_id : @id2 α = id := rfl

example : id2 x = x := by simp only [id2_eq_id, id_eq] -- works fine
example : id2 x = x := by rw [id2_eq_id, id_eq] -- succeeds


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

Instances of `traversable` for types from the core library
-/
import data.list.forall2
import data.set.lattice
import control.traversable.lemmas

universes u v

section option

open functor

variables {F G : Type u → Type u}
variables [applicative F] [applicative G]
variables [is_lawful_applicative F] [is_lawful_applicative G]

lemma option.id_traverse {α} (x : option α) : option.traverse id.mk x = x :=
by cases x; refl

@[nolint unused_arguments]
lemma option.comp_traverse {α β γ} (f : β → F γ) (g : α → G β) (x : option α) :
  option.traverse (comp.mk ∘ (<$>) f ∘ g) x =
  comp.mk (option.traverse f <$> option.traverse g x) :=
by cases x; simp! with functor_norm; refl

lemma option.traverse_eq_map_id {α β} (f : α → β) (x : option α) :
  traverse (id.mk ∘ f) x = id.mk (f <$> x) :=
by cases x; refl

variable (η : applicative_transformation F G)

lemma option.naturality {α β} (f : α → F β) (x : option α) :
  η (option.traverse f x) = option.traverse (@η _ ∘ f) x :=
by cases x with x; simp! [*] with functor_norm

end option

instance : is_lawful_traversable option :=
{ id_traverse := @option.id_traverse,
  comp_traverse := @option.comp_traverse,
  traverse_eq_map_id := @option.traverse_eq_map_id,
  naturality := @option.naturality,
  .. option.is_lawful_monad }

namespace list

variables {F G : Type u → Type u}
variables [applicative F] [applicative G]

section
variables [is_lawful_applicative F] [is_lawful_applicative G]

open applicative functor
open list (cons)

protected

@[nolint unused_arguments]
protected lemma comp_traverse {α β γ} (f : β → F γ) (g : α → G β) (x : list α) :
  list.traverse (comp.mk ∘ (<$>) f ∘ g) x =
  comp.mk (list.traverse f <$> list.traverse g x) :=
by induction x; simp! * with functor_norm; refl

protected lemma traverse_eq_map_id {α β} (f : α → β) (x : list α) :
  list.traverse (id.mk ∘ f) x = id.mk (f <$> x) :=
by induction x; simp! * with functor_norm; refl

variable (η : applicative_transformation F G)

protected lemma naturality {α β} (f : α → F β) (x : list α) :
  η (list.traverse f x) = list.traverse (@η _ ∘ f) x :=
by induction x; simp! * with functor_norm
open nat

instance : is_lawful_traversable.{u} list :=
{ id_traverse := @list.id_traverse,
  comp_traverse := @list.comp_traverse,
  traverse_eq_map_id := @list.traverse_eq_map_id,
  naturality := @list.naturality,
  .. list.is_lawful_monad }
end

section traverse
variables {α' β' : Type u} (f : α' → F β')

@[simp] lemma traverse_nil : traverse f ([] : list α') = (pure [] : F (list β')) := rfl

@[simp] lemma traverse_cons (a : α') (l : list α') :
  traverse f (a :: l) = (::) <$> f a <*> traverse f l := rfl

variables [is_lawful_applicative F]

@[simp] lemma traverse_append :
  ∀ (as bs : list α'), traverse f (as ++ bs) = (++) <$> traverse f as <*> traverse f bs
| [] bs :=
  have has_append.append ([] : list β') = id, by funext; refl,
  by simp [this] with functor_norm
| (a :: as) bs := by simp [traverse_append as bs] with functor_norm; congr

lemma mem_traverse {f : α' → set β'} :
  ∀(l : list α') (n : list β'), n ∈ traverse f l ↔ forall₂ (λb a, b ∈ f a) n l
| []      []      := by simp
| (a::as) []      := by simp; exact assume h, match h with end
| []      (b::bs) := by simp
| (a::as) (b::bs) :=
  suffices (b :: bs : list β') ∈ traverse f (a :: as) ↔ b ∈ f a ∧ bs ∈ traverse f as,
    by simp [mem_traverse as bs],
  iff.intro
    (assume ⟨_, ⟨b, hb, rfl⟩, _, hl, rfl⟩, ⟨hb, hl⟩)
    (assume ⟨hb, hl⟩, ⟨_, ⟨b, hb, rfl⟩, _, hl, rfl⟩)

end traverse

end list

namespace sum

section traverse
variables {σ : Type u}
variables {F G : Type u → Type u}
variables [applicative F] [applicative G]

open applicative functor
open list (cons)

protected lemma traverse_map {α β γ : Type u} (g : α → β) (f : β → G γ) (x : σ ⊕ α) :
  sum.traverse f (g <$> x) = sum.traverse (f ∘ g) x :=
by cases x; simp [sum.traverse, id_map] with functor_norm; refl

variables [is_lawful_applicative F] [is_lawful_applicative G]

protected lemma id_traverse {σ α} (x : σ ⊕ α) : sum.traverse id.mk x = x :=
by cases x; refl

@[nolint unused_arguments]
protected lemma comp_traverse {α β γ} (f : β → F γ) (g : α → G β) (x : σ ⊕ α) :
  sum.traverse (comp.mk ∘ (<$>) f ∘ g) x =
  comp.mk (sum.traverse f <$> sum.traverse g x) :=
by cases x; simp! [sum.traverse,map_id] with functor_norm; refl

protected lemma traverse_eq_map_id {α β} (f : α → β) (x : σ ⊕ α) :
  sum.traverse (id.mk ∘ f) x = id.mk (f <$> x) :=
by induction x; simp! * with functor_norm; refl

protected lemma map_traverse {α β γ} (g : α → G β) (f : β → γ) (x : σ ⊕ α) :
  (<$>) f <$> sum.traverse g x = sum.traverse ((<$>) f ∘ g) x :=
by cases x; simp [sum.traverse, id_map] with functor_norm; congr; refl

variable (η : applicative_transformation F G)

protected lemma naturality {α β} (f : α → F β) (x : σ ⊕ α) :
  η (sum.traverse f x) = sum.traverse (@η _ ∘ f) x :=
by cases x; simp! [sum.traverse] with functor_norm

end traverse

instance {σ : Type u} : is_lawful_traversable.{u} (sum σ) :=
{ id_traverse := @sum.id_traverse σ,
  comp_traverse := @sum.comp_traverse σ,
  traverse_eq_map_id := @sum.traverse_eq_map_id σ,
  naturality := @sum.naturality σ,
  .. sum.is_lawful_monad }

end sum


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Johannes Hölzl, Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.dfinsupp
import Mathlib.linear_algebra.basic
import Mathlib.PostPort

universes u_1 u_3 u_2 u_4

namespace Mathlib

/-!
# Properties of the semimodule `Π₀ i, M i`

Given an indexed collection of `R`-semimodules `M i`, the `R`-semimodule structure on `Π₀ i, M i`
is defined in `data.dfinsupp`.

In this file we define `linear_map` versions of various maps:

* `dfinsupp.lsingle a : M →ₗ[R] Π₀ i, M i`: `dfinsupp.single a` as a linear map;

* `dfinsupp.lmk s : (Π i : (↑s : set ι), M i) →ₗ[R] Π₀ i, M i`: `dfinsupp.single a` as a linear map;

* `dfinsupp.lapply i : (Π₀ i, M i) →ₗ[R] M`: the map `λ f, f i` as a linear map;

* `dfinsupp.lsum`: `dfinsupp.sum` or `dfinsupp.lift_add_hom` as a `linear_map`;

## Implementation notes

This file should try to mirror `linear_algebra.finsupp` where possible. The API of `finsupp` is
much more developed, but many lemmas in that file should be eligible to copy over.

## Tags

function with finite support, semimodule, linear algebra
-/

namespace dfinsupp

/-- `dfinsupp.mk` as a `linear_map`. -/
def lmk {ι : Type u_1} {R : Type u_2} {M : ι → Type u_3} [dec_ι : DecidableEq ι] [semiring R] [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (s : finset ι) : linear_map R ((i : ↥↑s) → M ↑i) (dfinsupp fun (i : ι) => M i) :=
  linear_map.mk (mk s) sorry sorry

/-- `dfinsupp.single` as a `linear_map` -/
def lsingle {ι : Type u_1} {R : Type u_2} {M : ι → Type u_3} [dec_ι : DecidableEq ι] [semiring R] [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (i : ι) : linear_map R (M i) (dfinsupp fun (i : ι) => M i) :=
  linear_map.mk (single i) sorry sorry

/-- Two `R`-linear maps from `Π₀ i, M i` which agree on each `single i x` agree everywhere. -/
theorem lhom_ext {ι : Type u_1} {R : Type u_2} {M : ι → Type u_3} {N : Type u_4} [dec_ι : DecidableEq ι] [semiring R] [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] [add_comm_monoid N] [semimodule R N] {φ : linear_map R (dfinsupp fun (i : ι) => M i) N} {ψ : linear_map R (dfinsupp fun (i : ι) => M i) N} (h : ∀ (i : ι) (x : M i), coe_fn φ (single i x) = coe_fn ψ (single i x)) : φ = ψ :=
  linear_map.to_add_monoid_hom_injective (add_hom_ext h)

/-- Two `R`-linear maps from `Π₀ i, M i` which agree on each `single i x` agree everywhere.

See note [partially-applied ext lemmas].
After apply this lemma, if `M = R` then it suffices to verify `φ (single a 1) = ψ (single a 1)`. -/
theorem lhom_ext' {ι : Type u_1} {R : Type u_2} {M : ι → Type u_3} {N : Type u_4} [dec_ι : DecidableEq ι] [semiring R] [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] [add_comm_monoid N] [semimodule R N] {φ : linear_map R (dfinsupp fun (i : ι) => M i) N} {ψ : linear_map R (dfinsupp fun (i : ι) => M i) N} (h : ∀ (i : ι), linear_map.comp φ (lsingle i) = linear_map.comp ψ (lsingle i)) : φ = ψ :=
  lhom_ext fun (i : ι) => linear_map.congr_fun (h i)

/-- Interpret `λ (f : Π₀ i, M i), f i` as a linear map. -/
def lapply {ι : Type u_1} {R : Type u_2} {M : ι → Type u_3} [semiring R] [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (i : ι) : linear_map R (dfinsupp fun (i : ι) => M i) (M i) :=
  linear_map.mk (fun (f : dfinsupp fun (i : ι) => M i) => coe_fn f i) sorry sorry

@[simp] theorem lmk_apply {ι : Type u_1} {R : Type u_2} {M : ι → Type u_3} [dec_ι : DecidableEq ι] [semiring R] [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (s : finset ι) (x : (i : ↥↑s) → (fun (i : ι) => M i) ↑i) : coe_fn (lmk s) x = mk s x :=
  rfl

@[simp] theorem lsingle_apply {ι : Type u_1} {R : Type u_2} {M : ι → Type u_3} [dec_ι : DecidableEq ι] [semiring R] [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (i : ι) (x : M i) : coe_fn (lsingle i) x = single i x :=
  rfl

@[simp] theorem lapply_apply {ι : Type u_1} {R : Type u_2} {M : ι → Type u_3} [semiring R] [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] (i : ι) (f : dfinsupp fun (i : ι) => M i) : coe_fn (lapply i) f = coe_fn f i :=
  rfl

/-- The `dfinsupp` version of `finsupp.lsum`. -/
def lsum {ι : Type u_1} {R : Type u_2} {M : ι → Type u_3} {N : Type u_4} [dec_ι : DecidableEq ι] [semiring R] [(i : ι) → add_comm_monoid (M i)] [(i : ι) → semimodule R (M i)] [add_comm_monoid N] [semimodule R N] : ((i : ι) → linear_map R (M i) N) ≃+ linear_map R (dfinsupp fun (i : ι) => M i) N :=
  add_equiv.mk
    (fun (F : (i : ι) → linear_map R (M i) N) =>
      linear_map.mk ⇑(sum_add_hom fun (i : ι) => linear_map.to_add_monoid_hom (F i)) sorry sorry)
    (fun (F : linear_map R (dfinsupp fun (i : ι) => M i) N) (i : ι) => linear_map.comp F (lsingle i)) sorry sorry sorry


import Lean

def checkWithMkMatcherInput (matcher : Lean.Name) : Lean.MetaM Unit :=
  Lean.Meta.Match.withMkMatcherInput matcher fun input => do
  let res ← Lean.Meta.Match.mkMatcher input
  let origMatcher ← Lean.getConstInfo matcher
  if not <| input.matcherName == matcher then
    throwError "matcher name not reconstructed correctly: {matcher} ≟ {input.matcherName}"

  let lCtx ← Lean.getLCtx
  let fvars ← Lean.collectFVars {} res.matcher
  let closure ← Lean.Meta.Closure.mkLambda (fvars.fvarSet.toList.toArray.map lCtx.get!) res.matcher

  let origTy := origMatcher.value!
  let newTy ← closure
  if not <| ←Lean.Meta.isDefEq origTy newTy then
    throwError "matcher {matcher} does not round-trip correctly:\n{origTy} ≟ {newTy}"

set_option smartUnfolding false

def f (xs : List Nat) : List Bool :=
xs.map fun
  | 0 => true
  | _ => false
#eval checkWithMkMatcherInput ``f.match_1

#eval f [1, 2, 0, 2]

theorem ex1 : f [1, 0, 2] = [false, true, false] :=
rfl

#check f

set_option pp.raw true
set_option pp.raw.maxDepth 10
set_option trace.Elab.step true in
def g (xs : List Nat) : List Bool :=
xs.map <| by {
  intro
    | 0 => exact true
    | _ => exact false
}

theorem ex2 : g [1, 0, 2] = [false, true, false] :=
rfl

theorem ex3 {p q r : Prop} : p ∨ q → r → (q ∧ r) ∨ (p ∧ r) :=
by intro
 | Or.inl hp, h => { apply Or.inr; apply And.intro; assumption; assumption }
 | Or.inr hq, h => { apply Or.inl; exact ⟨hq, h⟩ }
#eval checkWithMkMatcherInput ``ex3.match_1

inductive C
| mk₁ : Nat → C
| mk₂ : Nat → Nat → C

def C.x : C → Nat
| C.mk₁ x   => x
| C.mk₂ x _ => x
#eval checkWithMkMatcherInput ``C.x.match_1

def head : {α : Type} → List α → Option α
| _, a::as => some a
| _, _     => none
#eval checkWithMkMatcherInput ``head.match_1

theorem ex4 : head [1, 2] = some 1 :=
rfl

def head2 : {α : Type} → List α → Option α :=
@fun
  | _, a::as => some a
  | _, _     => none

theorem ex5 : head2 [1, 2] = some 1 :=
rfl

def head3 {α : Type} (xs : List α) : Option α :=
let rec aux : {α : Type} → List α → Option α
  | _, a::as => some a
  | _, _     => none;
aux xs

theorem ex6 : head3 [1, 2] = some 1 :=
rfl

inductive Vec.{u} (α : Type u) : Nat → Type u
| nil : Vec α 0
| cons {n} (head : α) (tail : Vec α n) : Vec α (n+1)

def Vec.mapHead1 {α β δ} : {n : Nat} → Vec α n → Vec β n → (α → β → δ) → Option δ
| _,   nil,       nil,       f => none
| _, cons a as, cons b bs,   f => some (f a b)
#eval checkWithMkMatcherInput ``Vec.mapHead1.match_1

def Vec.mapHead2 {α β δ} : {n : Nat} → Vec α n → Vec β n → (α → β → δ) → Option δ
| _, nil,            nil,         f => none
| _, @cons _ n a as, cons b bs,   f => some (f a b)
#eval checkWithMkMatcherInput ``Vec.mapHead2.match_1

def Vec.mapHead3 {α β δ} : {n : Nat} → Vec α n → Vec β n → (α → β → δ) → Option δ
| _, nil,            nil,         f => none
| _, cons (tail := as) (head := a), cons b bs,   f => some (f a b)

inductive Foo
| mk₁ (x y z w : Nat)
| mk₂ (x y z w : Nat)

def Foo.z : Foo → Nat
| mk₁ (z := z) .. => z
| mk₂ (z := z) .. => z
#eval checkWithMkMatcherInput ``Foo.z.match_1

#eval (Foo.mk₁ 10 20 30 40).z

theorem ex7 : (Foo.mk₁ 10 20 30 40).z = 30 :=
rfl

def Foo.addY? : Foo × Foo → Option Nat
| (mk₁ (y := y₁) .., mk₁ (y := y₂) ..) => some (y₁ + y₂)
| _ => none
#eval checkWithMkMatcherInput ``Foo.addY?.match_1

#eval Foo.addY? (Foo.mk₁ 1 2 3 4, Foo.mk₁ 10 20 30 40)

theorem ex8 : Foo.addY? (Foo.mk₁ 1 2 3 4, Foo.mk₁ 10 20 30 40) = some 22 :=
rfl

instance {α} : Inhabited (Sigma fun m => Vec α m) :=
⟨⟨0, Vec.nil⟩⟩

partial def filter {α} (p : α → Bool) : {n : Nat} → Vec α n → Sigma fun m => Vec α m
| _, Vec.nil        => ⟨0, Vec.nil⟩
| _, Vec.cons x xs  => match p x, filter p xs with
  | true,  ⟨_, ys⟩ => ⟨_, Vec.cons x ys⟩
  | false, ys      => ys
#eval checkWithMkMatcherInput ``filter.match_1

inductive Bla
| ofNat  (x : Nat)
| ofBool (x : Bool)

def Bla.optional? : Bla → Option Nat
| ofNat x  => some x
| ofBool _ => none
#eval checkWithMkMatcherInput ``Bla.optional?.match_1

def Bla.isNat? (b : Bla) : Option { x : Nat // optional? b = some x } :=
match b.optional? with
| some y => some ⟨y, rfl⟩
| none   => none
#eval checkWithMkMatcherInput ``Bla.isNat?.match_1

def foo (b : Bla) : Option Nat := b.optional?
theorem fooEq (b : Bla) : foo b = b.optional? :=
rfl

def Bla.isNat2? (b : Bla) : Option { x : Nat // optional? b = some x } :=
match h:foo b with
| some y => some ⟨y, Eq.trans (fooEq b).symm h⟩
| none   => none
#eval checkWithMkMatcherInput ``Bla.isNat2?.match_1

def foo2 (x : Nat) : Nat :=
match x, rfl : (y : Nat) → x = y → Nat with
| 0,   h => 0
| x+1, h => 1
#eval checkWithMkMatcherInput ``foo2.match_1


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Minchao Wu
-/
import meta.rb_map
import tactic.core
/-!
# `#explode` command

Displays a proof term in a line by line format somewhat akin to a Fitch style
proof or the Metamath proof style.
-/

open expr tactic

namespace tactic
namespace explode

@[derive inhabited]
inductive status : Type | reg | intro | lam | sintro

/--
A type to distinguish introduction or elimination rules represented as
strings from theorems referred to by their names.
-/
meta inductive thm : Type
| expr (e : expr)
| name (n : name)
| string (s : string)

/--
Turn a thm into a string.
-/
meta def thm.to_string : thm → string
| (thm.expr e) := e.to_string
| (thm.name n) := n.to_string
| (thm.string s) := s

meta structure entry : Type :=
(expr : expr)
(line : nat)
(depth : nat)
(status : status)
(thm : thm)
(deps : list nat)

meta def pad_right (l : list string) : list string :=
let n := l.foldl (λ r (s:string), max r s.length) 0 in
l.map $ λ s, nat.iterate (λ s, s.push ' ') (n - s.length) s

@[derive inhabited]
meta structure entries : Type := mk' ::
(s : expr_map entry)
(l : list entry)

meta def entries.find (es : entries) (e : expr) : option entry := es.s.find e
meta def entries.size (es : entries) : ℕ := es.s.size

meta def entries.add : entries → entry → entries
| es@⟨s, l⟩ e := if s.contains e.expr then es else ⟨s.insert e.expr e, e :: l⟩

meta def entries.head (es : entries) : option entry := es.l.head'

meta def format_aux : list string → list string → list string → list entry → tactic format
| (line :: lines) (dep :: deps) (thm :: thms) (en :: es) := do
  fmt ← do
  { let margin := string.join (list.repeat " │" en.depth),
    let margin := match en.status with
      | status.sintro := " ├" ++ margin
      | status.intro := " │" ++ margin ++ " ┌"
      | status.reg := " │" ++ margin ++ ""
      | status.lam := " │" ++ margin ++ ""
      end,
    p ← infer_type en.expr >>= pp,
    let lhs :=  line ++ "│" ++ dep ++ "│ " ++ thm ++ margin ++ " ",
    return $ format.of_string lhs ++ (p.nest lhs.length).group ++ format.line },
  (++ fmt) <$> format_aux lines deps thms es
| _ _ _ _ := return format.nil

meta instance : has_to_tactic_format entries :=
⟨λ es : entries,
  let lines := pad_right $ es.l.map (λ en, to_string en.line),
      deps  := pad_right $ es.l.map (λ en, string.intercalate "," (en.deps.map to_string)),
      thms  := pad_right $ es.l.map (λ en, (entry.thm en).to_string) in
  format_aux lines deps thms es.l⟩

meta def append_dep (filter : expr → tactic unit)
 (es : entries) (e : expr) (deps : list nat) : tactic (list nat) :=
do { ei ← es.find e,
  filter ei.expr,
  return (ei.line :: deps) }
<|> return deps

meta def may_be_proof (e : expr) : tactic bool :=
do expr.sort u ← infer_type e >>= infer_type,
   return $ bnot u.nonzero

end explode
open explode

meta mutual def explode.core, explode.args (filter : expr → tactic unit)
with explode.core : expr → bool → nat → entries → tactic entries
| e@(lam n bi d b) si depth es := do
  m ← mk_fresh_name,
  let l := local_const m n bi d,
  let b' := instantiate_var b l,
  if si then
    let en : entry := ⟨l, es.size, depth, status.sintro, thm.name n, []⟩ in do
    es' ← explode.core b' si depth (es.add en),
    return $ es'.add ⟨e, es'.size, depth, status.lam, thm.string "∀I", [es.size, es'.size - 1]⟩
  else do
    let en : entry := ⟨l, es.size, depth, status.intro, thm.name n, []⟩,
    es' ← explode.core b' si (depth + 1) (es.add en),
    -- in case of a "have" clause, the b' here has an annotation
    deps' ← explode.append_dep filter es' b'.erase_annotations [],
    deps' ← explode.append_dep filter es' l deps',
    return $ es'.add ⟨e, es'.size, depth, status.lam, thm.string "∀I", deps'⟩
| e@(elet n t a b) si depth es := explode.core (reduce_lets e) si depth es
| e@(macro n l) si depth es := explode.core l.head si depth es
| e si depth es := filter e >>
  match get_app_fn_args e with
  | (nm@(const n _), args) :=
    explode.args e args depth es (thm.expr nm) []
  | (fn, []) := do
    let en : entry := ⟨fn, es.size, depth, status.reg, thm.expr fn, []⟩,
    return (es.add en)
  | (fn, args) := do
    es' ← explode.core fn ff depth es,
    -- in case of a "have" clause, the fn here has an annotation
    deps ← explode.append_dep filter es' fn.erase_annotations [],
    explode.args e args depth es' (thm.string "∀E") deps
  end
with explode.args : expr → list expr → nat → entries → thm → list nat → tactic entries
| e (arg :: args) depth es thm deps := do
  es' ← explode.core arg ff depth es <|> return es,
  deps' ← explode.append_dep filter es' arg deps,
  explode.args e args depth es' thm deps'
| e [] depth es thm deps :=
  return (es.add ⟨e, es.size, depth, status.reg, thm, deps.reverse⟩)

meta def explode_expr (e : expr) (hide_non_prop := tt) : tactic entries :=
let filter := if hide_non_prop then λ e, may_be_proof e >>= guardb else λ _, skip in
tactic.explode.core filter e tt 0 (default _)

meta def explode (n : name) : tactic unit :=
do const n _ ← resolve_name n | fail "cannot resolve name",
  d ← get_decl n,
  v ← match d with
  | (declaration.defn _ _ _ v _ _) := return v
  | (declaration.thm _ _ _ v)      := return v.get
  | _                  := fail "not a definition"
  end,
  t ← pp d.type,
  explode_expr v <* trace (to_fmt n ++ " : " ++ t) >>= trace

setup_tactic_parser

/--
`#explode decl_name` displays a proof term in a line-by-line format somewhat akin to a Fitch-style
proof or the Metamath proof style.
`#explode_widget decl_name` renders a widget that displays an `#explode` proof.

`#explode iff_true_intro` produces

```lean
iff_true_intro : ∀ {a : Prop}, a → (a ↔ true)
0│   │ a         ├ Prop
1│   │ h         ├ a
2│   │ hl        │ ┌ a
3│   │ trivial   │ │ true
4│2,3│ ∀I        │ a → true
5│   │ hr        │ ┌ true
6│5,1│ ∀I        │ true → a
7│4,6│ iff.intro │ a ↔ true
8│1,7│ ∀I        │ a → (a ↔ true)
9│0,8│ ∀I        │ ∀ {a : Prop}, a → (a ↔ true)
```

In more detail:

The output of `#explode` is a Fitch-style proof in a four-column diagram modeled after Metamath
proof displays like [this](http://us.metamath.org/mpeuni/ru.html). The headers of the columns are
"Step", "Hyp", "Ref", "Type" (or "Expression" in the case of Metamath):
* Step: An increasing sequence of numbers to number each step in the proof, used in the Hyp field.
* Hyp: The direct children of the current step. Most theorems are implications like `A -> B -> C`,
  and so on the step proving `C` the Hyp field will refer to the steps that prove `A` and `B`.
* Ref: The name of the theorem being applied. This is well-defined in Metamath, but in Lean there
  are some special steps that may have long names because the structure of proof terms doesn't
  exactly match this mold.
  * If the theorem is `foo (x y : Z) : A x -> B y -> C x y`:
    * the Ref field will contain `foo`,
    * `x` and `y` will be suppressed, because term construction is not interesting, and
    * the Hyp field will reference steps proving `A x` and `B y`. This corresponds to a proof term
      like `@foo x y pA pB` where `pA` and `pB` are subproofs.
  * If the head of the proof term is a local constant or lambda, then in this case the Ref will
    say `∀E` for forall-elimination. This happens when you have for example `h : A -> B` and
    `ha : A` and prove `b` by `h ha`; we reinterpret this as if it said `∀E h ha` where `∀E` is
    (n-ary) modus ponens.
  * If the proof term is a lambda, we will also use `∀I` for forall-introduction, referencing the
    body of the lambda. The indentation level will increase, and a bracket will surround the proof
    of the body of the lambda, starting at a proof step labeled with the name of the lambda variable
    and its type, and ending with the `∀I` step. Metamath doesn't have steps like this, but the
    style is based on Fitch proofs in first-order logic.
* Type: This contains the type of the proof term, the theorem being proven at the current step.
  This proof layout differs from `#print` in using lots of intermediate step displays so that you
  can follow along and don't have to see term construction steps because they are implicitly in the
  intermediate step displays.

Also, it is common for a Lean theorem to begin with a sequence of lambdas introducing local
constants of the theorem. In order to minimize the indentation level, the `∀I` steps at the end of
the proof will be introduced in a group and the indentation will stay fixed. (The indentation
brackets are only needed in order to delimit the scope of assumptions, and these assumptions
have global scope anyway so detailed tracking is not necessary.)
-/
@[user_command]
meta def explode_cmd (_ : parse $ tk "#explode") : parser unit :=
do n ← ident,
  explode n
.

add_tactic_doc
{ name       := "#explode / #explode_widget",
  category   := doc_category.cmd,
  decl_names := [`tactic.explode_cmd, `tactic.explode_widget_cmd],
  inherit_description_from := `tactic.explode_cmd,
  tags       := ["proof display", "widgets"] }

end tactic


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Yury Kudryashov.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.transform_decl
import Mathlib.tactic.algebra
import Mathlib.PostPort

universes l

namespace Mathlib

/-!
# Transport multiplicative to additive

This file defines an attribute `to_additive` that can be used to
automatically transport theorems and definitions (but not inductive
types and structures) from a multiplicative theory to an additive theory.

Usage information is contained in the doc string of `to_additive.attr`.

### Missing features

* Automatically transport structures and other inductive types.

* For structures, automatically generate theorems like `group α ↔
  add_group (additive α)`.

* Rewrite rules for the last part of the name that work in more
  cases. E.g., we can replace `monoid` with `add_monoid` etc.
-/

namespace to_additive

/-- An auxiliary attribute used to store the names of the additive versions of declarations
that have been processed by `to_additive`. -/
/-- A command that can be used to have future uses of `to_additive` change the `src` namespace
to the `tgt` namespace.

For example:
```
run_cmd to_additive.map_namespace `quotient_group `quotient_add_group
```

Later uses of `to_additive` on declarations in the `quotient_group` namespace will be created
in the `quotient_add_group` namespaces.
-/
/-- `value_type` is the type of the arguments that can be provided to `to_additive`.
`to_additive.parser` parses the provided arguments into `name` for the target and an
optional doc string. -/
structure value_type
where
  tgt : name
  doc : Option string

/-- `add_comm_prefix x s` returns `"comm_" ++ s` if `x = tt` and `s` otherwise. -/
/-- Dictionary used by `to_additive.guess_name` to autogenerate names. -/
/-- Autogenerate target name for `to_additive`. -/
/-- Return the provided target name or autogenerate one if one was not provided. -/
/-- the parser for the arguments to `to_additive` -/
/-- Add the `aux_attr` attribute to the structure fields of `src`
so that future uses of `to_additive` will map them to the corresponding `tgt` fields. -/
/--
The attribute `to_additive` can be used to automatically transport theorems
and definitions (but not inductive types and structures) from a multiplicative
theory to an additive theory.

To use this attribute, just write:

```
@[to_additive]
theorem mul_comm' {α} [comm_semigroup α] (x y : α) : x * y = y * x := comm_semigroup.mul_comm
```

This code will generate a theorem named `add_comm'`.  It is also
possible to manually specify the name of the new declaration, and
provide a documentation string:

```
@[to_additive add_foo "add_foo doc string"]
/-- foo doc string -/


/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.monotonicity.basic
import Mathlib.control.traversable.default
import Mathlib.control.traversable.derive
import Mathlib.Lean3Lib.data.dlist
import Mathlib.PostPort

universes u v u_1 u_2 l

namespace Mathlib

namespace tactic.interactive

/--
`(prefix,left,right,suffix) ← match_assoc unif l r` finds the
longest prefix and suffix common to `l` and `r` and
returns them along with the differences  -/
def apply_rel {α : Sort u} (R : α → α → Sort v) {x : α} {y : α} (x' : α) (y' : α) (h : R x y) (hx : x = x') (hy : y = y') : R x' y' :=
  eq.mpr sorry (eq.mpr sorry h)

/-- tactic-facing function, similar to `interactive.tactic.generalize` with the
exception that meta variables -/
def list.minimum_on {α : Type u_1} {β : Type u_2} [linear_order β] (f : α → β) : List α → List α :=
  sorry

/--
- `mono` applies a monotonicity rule.
- `mono*` applies monotonicity rules repetitively.
- `mono with x ≤ y` or `mono with [0 ≤ x,0 ≤ y]` creates an assertion for the listed
  propositions. Those help to select the right monotonicity rule.
- `mono left` or `mono right` is useful when proving strict orderings:
   for `x + y < w + z` could be broken down into either
    - left:  `x ≤ w` and `y < z` or
    - right: `x < w` and `y ≤ z`
- `mono using [rule1,rule2]` calls `simp [rule1,rule2]` before applying mono.
- The general syntax is `mono '*'? ('with' hyp | 'with' [hyp1,hyp2])? ('using' [hyp1,hyp2])? mono_cfg?

To use it, first import `tactic.monotonicity`.

Here is an example of mono:

```lean
example (x y z k : ℤ)
  (h : 3 ≤ (4 : ℤ))
  (h' : z ≤ y) :
  (k + 3 + x) - y ≤ (k + 4 + x) - z :=
begin
  mono, -- unfold `(-)`, apply add_le_add
  { -- ⊢ k + 3 + x ≤ k + 4 + x
    mono, -- apply add_le_add, refl
    -- ⊢ k + 3 ≤ k + 4
    mono },
  { -- ⊢ -y ≤ -z
    mono /- apply neg_le_neg -/ }
end
```

More succinctly, we can prove the same goal as:

```lean
example (x y z k : ℤ)
  (h : 3 ≤ (4 : ℤ))
  (h' : z ≤ y) :
  (k + 3 + x) - y ≤ (k + 4 + x) - z :=
by mono*
```

-/
/--
transforms a goal of the form `f x ≼ f y` into `x ≤ y` using lemmas
marked as `monotonic`.

Special care is taken when `f` is the repeated application of an
associative operator and if the operator is commutative
-/
/-- (repeat_until_or_at_most n t u): repeat tactic `t` at most n times or until u succeeds -/
inductive rep_arity
where
| one : rep_arity
| exactly : ℕ → rep_arity
| many : rep_arity

/--

`ac_mono` reduces the `f x ⊑ f y`, for some relation `⊑` and a
monotonic function `f` to `x ≺ y`.

`ac_mono*` unwraps monotonic functions until it can't.

`ac_mono^k`, for some literal number `k` applies monotonicity `k`
times.

`ac_mono h`, with `h` a hypothesis, unwraps monotonic functions and
uses `h` to solve the remaining goal. Can be combined with `*` or `^k`:
`ac_mono* h`

`ac_mono : p` asserts `p` and uses it to discharge the goal result
unwrapping a series of monotonic functions. Can be combined with * or
^k: `ac_mono* : p`

In the case where `f` is an associative or commutative operator,
`ac_mono` will consider any possible permutation of its arguments and
use the one the minimizes the difference between the left-hand side
and the right-hand side.

To use it, first import `tactic.monotonicity`.

`ac_mono` can be used as follows:

```lean
example (x y z k m n : ℕ)
  (h₀ : z ≥ 0)
  (h₁ : x ≤ y) :
  (m + x + n) * z + k ≤ z * (y + n + m) + k :=
begin
  ac_mono,
  -- ⊢ (m + x + n) * z ≤ z * (y + n + m)
  ac_mono,
  -- ⊢ m + x + n ≤ y + n + m
  ac_mono,
end
```

As with `mono*`, `ac_mono*` solves the goal in one go and so does
`ac_mono* h₁`. The latter syntax becomes especially interesting in the
following example:

```lean
example (x y z k m n : ℕ)
  (h₀ : z ≥ 0)
  (h₁ : m + x + n ≤ y + n + m) :
  (m + x + n) * z + k ≤ z * (y + n + m) + k :=
by ac_mono* h₁.
```

By giving `ac_mono` the assumption `h₁`, we are asking `ac_refl` to
stop earlier than it would normally would.
-/
/-
TODO(Simon): with `ac_mono h` and `ac_mono : p` split the remaining
  gaol if the provided rule does not solve it completely.
-/


/-
## Finite interaction trees

The semantics framework for this project is extremely inspired by the Vellvm
project [1] and is essentially centered around interaction trees and monadic
transformers.

Interactions trees are a particular instance of the freer monad; essentially,
an ITree is a program that can have side effets through *interactions*, and
these interactions can either be interpreted into the program or kept as
observable side-effects.

When giving semantics to a program, one usually starts with a rather simple
ITree where most of the complex features of the language (memory, I/O,
exceptions, randomness, non-determinism, etc) are hidden behind interactions.
The interactions are then interpreted, which consists of (1) enriching the
program's environment by a monadic transformation, and (2) replacing the
interaction with an actual implementation.

This approach allows monadic domains to be used while keeping each family of
interactions separate. This is relevant for Vellvm as LLVM IR has many complex
features, and even more relevant for MLIR since each dialect can bring more
interactions and environment transforms and all of them have to be studied and
defined independently.

The datatype of interaction trees normally has built-in non-termination by
being defined coinductively. Support for coinduction is still limited in
Lean 4, so we currently use a finite version of ITrees (hence called Fitree)
and we only model programs that always terminate.

[1]: https://github.com/vellvm/vellvm
-/

import MLIR.Semantics.SimpItree
import MLIR.Dialects
import MLIR.Util.WriterT

/- Extendable effect families -/

abbrev to1 (E: Type → Type u) (F: Type → Type v) :=
  ∀ T, E T → F T
abbrev sum1 (E F: Type → Type) :=
  fun T => E T ⊕ F T
inductive Void1: Type → Type :=

infixr:40 " ~> " => to1
infixr:60 " +' " => sum1

class Member (E: Type → Type) (F: Type → Type) where
  inject : E ~> F

instance MemberId {E}: Member E E where
  inject := (fun _ => id)

instance MemberSumL {E F G} [Member E F]: Member E (F +' G) where
  inject T := Sum.inl ∘ Member.inject T

instance MemberSumR {E F G} [Member E G]: Member E (F +' G) where
  inject T := Sum.inr ∘ Member.inject T

instance MemberSum {E F G H} [Member E G] [Member F H]:
    Member (E +' F) (G +' H) where
  inject T := Sum.cases (Member.inject T) (Member.inject T)

instance MemberVoid1 {E}:
    Member Void1 E where
  inject _ e := nomatch e

-- Effects can now be put in context automatically by typeclass resolution
example E:      Member E E := inferInstance
example E F:    Member E (E +' F) := inferInstance
example E F:    Member E (F +' (F +' E)) := inferInstance
example E F G:  Member (E +' F) (E +' F +' G) := inferInstance

/- The monadic domain; essentially finite Interaction Trees -/

inductive Fitree (E: Type → Type) (R: Type) where
  | Ret (r: R): Fitree E R
  | Vis {T: Type} (e: E T) (k: T → Fitree E R): Fitree E R

def Fitree.map {E R R'} (f: R → R'): Fitree E R -> Fitree E R'
| .Ret r => .Ret (f r)
| .Vis e k => .Vis e (fun t => (k t).map f)

@[simp_itree]
def Fitree.ret {E R}: R → Fitree E R :=
  Fitree.Ret

@[simp_itree]
def Fitree.trigger {E: Type → Type} {F: Type → Type} {T} [Member E F]
    (e: E T): Fitree F T :=
  Fitree.Vis (Member.inject _ e) Fitree.ret

@[simp_itree]
def Fitree.bind {E R T} (t: Fitree E T) (k: T → Fitree E R) :=
  match t with
  | Ret r => k r
  | Vis e k' => Vis e (fun r => bind (k' r) k)

instance {E}: Monad (Fitree E) where
  pure := Fitree.ret
  bind := Fitree.bind

-- Since we only use finite ITrees, we can actually run them when they're
-- fully interpreted (which leaves only the Ret constructor)
@[simp_itree]
def Fitree.run {R}: Fitree Void1 R → R
  | Ret r => r
  | Vis e _ => nomatch e

@[simp] theorem Fitree.run_ret:
  Fitree.run (Fitree.ret r) = r := rfl

@[simp_itree]
def Fitree.translate {E F R} (f: E ~> F): Fitree E R → Fitree F R
  | Ret r => Ret r
  | Vis e k => Vis (f _ e) (fun r => translate f (k r))

@[simp] theorem Fitree.translate_ret:
  Fitree.translate f (Fitree.ret r) = Fitree.ret r := rfl
@[simp] theorem Fitree.translate_vis:
    Fitree.translate f (Vis e k) = Vis (f _ e) (fun r => translate f (k r)) :=
  rfl

@[simp_itree]
def Fitree.case (h₁: E ~> G) (h₂: F ~> G): E +' F ~> G :=
  fun R ef => match ef with
  | Sum.inl e => h₁ R e
  | Sum.inr f => h₂ R f

@[simp] theorem Fitree.case_left:
  Fitree.case h₁ h₂ _ (Sum.inl e) = h₁ _ e := rfl
@[simp] theorem Fitree.case_right:
  Fitree.case h₁ h₂ _ (Sum.inr e) = h₂ _ e := rfl

/-
### Monadic interpretation
-/

@[simp_itree]
def Fitree.interp {M} [Monad M] {E} (h: E ~> M) {R}: Fitree E R → M R
  | .Ret r => pure r
  | .Vis e k => Bind.bind (h _ e) (fun t => interp h (k t))

@[simp_itree]
def Fitree.interp' {E F} (h: E ~> Fitree Void1) {R} (t: Fitree (E +' F) R):
    Fitree F R :=
  interp (Fitree.case
    (fun _ e => (h _ e).translate $ fun _ e => nomatch e)
    (fun _ e => Fitree.trigger e)) t

-- Interp `F` by lifting into a monad transformer (this is used when
-- interpreting `E +' F` into the monad)
def Fitree.liftHandler {F M} [MonadLiftT (Fitree F) M]: F ~> M := fun R e =>
  monadLift (Fitree.trigger e: Fitree F R)

-- Interpretation into various predefined monads. These are predefined so that
-- rewriting theorems that expose the monad structure can be provided.

@[simp_itree]
def Fitree.interpState {M S} [Monad M] {E} (h: E ~> StateT S M):
    forall {R}, Fitree E R → StateT S M R :=
  interp h

@[simp_itree]
def Fitree.interpWriter {M} [Monad M] {E} (h: E ~> WriterT M):
    forall {R}, Fitree E R → WriterT M R :=
  interp h

@[simp_itree]
def Fitree.interpOption {M} [Monad M] {E} (h: E ~> OptionT M):
    forall {R}, Fitree E R → OptionT M R :=
  interp h

@[simp_itree]
def Fitree.interpExcept {M ε} [Monad M] {E} (h: E ~> ExceptT ε M) {R}:
    Fitree E R → ExceptT ε M R :=
  interp h

/-
### Combinator identities

The following theorems act as the main interface for computation on ITrees. We
don't unfold definitions because Lean 4 doesn't yet have the match-unfolding
behavior of Coq's `simpl` tactic, and runs into performance issues as unfolded
terms grow larger. Instead, we aggressively rewrite the following simplifying
equalities.
-/

@[simp] theorem Fitree.bind_ret:
  Fitree.bind (Fitree.ret r) k = k r := rfl

@[simp] theorem Fitree.bind_Ret:
  Fitree.bind (Fitree.Ret r) k = k r := rfl

@[simp] theorem Fitree.bind_ret':
    Fitree.bind t (fun r => Fitree.ret r) = t := by
  induction t with
  | Ret _ => rfl
  | Vis _ _ ih => simp [bind, ih]

@[simp] theorem Fitree.bind_Ret':
    Fitree.bind t (fun r => Fitree.Ret r) = t := by
  induction t with
  | Ret _ => rfl
  | Vis _ _ ih => simp [bind, ih]

@[simp] theorem Fitree.bind_bind:
    Fitree.bind (Fitree.bind t k) k' =
    Fitree.bind t (fun x => Fitree.bind (k x) k') := by
  induction t with
  | Ret _ => rfl
  | Vis _ _ ih => simp [bind, ih]

@[simp] theorem Fitree.pure_is_ret:
  @Pure.pure (Fitree E) _ _ r = Fitree.ret r := rfl

@[simp] theorem Fitree.bind_is_bind:
  @Bind.bind (Fitree E) _ _ _  t k = Fitree.bind t k := rfl

@[simp] theorem Fitree.StateT_bind_is_bind (k: T → S → Fitree E (R × S)):
  StateT.bind (m := Fitree E) t k =
    fun s => Fitree.bind (t s) (fun (x,s) => k x s) := rfl

@[simp] theorem Fitree.WriterT_bind_is_bind (k: T → Fitree E (R × String)):
  WriterT.bind (m := Fitree E) t k =
    Fitree.bind t (WriterT.bindCont k) := rfl

@[simp] theorem Fitree.OptionT_bind_is_bind (k: T → Fitree E (Option R)):
  OptionT.bind (m := Fitree E) t k =
    Fitree.bind t (fun
      | some x => k x
      | none => Fitree.ret none) := rfl

@[simp] theorem Fitree.ExceptT_bind_is_bind (k: T → Fitree E (Except ε R)):
  ExceptT.bind (m := Fitree E) t k = Fitree.bind t (ExceptT.bindCont k) := rfl

@[simp] theorem Fitree.liftHandler_StateT_is_StateT_lift:
  @Fitree.liftHandler F (StateT S (Fitree F)) _ _ e =
  fun s => Fitree.bind (Fitree.trigger e) (fun x => Fitree.ret (x, s)) := rfl

@[simp] theorem Fitree.liftHandler_WriterT_is_WriterT_lift:
  @Fitree.liftHandler F (WriterT (Fitree F)) _ _ e =
  Fitree.bind (Fitree.trigger e) (fun x => Fitree.ret (x, "")) := rfl

@[simp] theorem Fitree.liftHandler_OptionT_is_OptionT_lift:
  @Fitree.liftHandler F (OptionT (Fitree F)) _ _ e =
  Fitree.bind (Fitree.trigger e) (fun x => Fitree.ret (some x)) := rfl

@[simp] theorem Fitree.liftHandler_ExceptT_is_ExceptT_lift:
  @Fitree.liftHandler F (ExceptT ε (Fitree F)) _ _ e =
  Fitree.bind (Fitree.trigger e) (fun x => Fitree.ret (Except.ok x)) := rfl

@[simp] theorem Member.injectId:
  @Member.inject E E MemberId _ e = e := rfl

@[simp] theorem Member.injectSumL [Member E F]:
  @Member.inject E (F +' G) MemberSumL _ e = Sum.inl (Member.inject _ e) := rfl

@[simp] theorem Member.injectSumR [Member E G]:
  @Member.inject E (F +' G) MemberSumR _ e = Sum.inr (Member.inject _ e) := rfl

@[simp] theorem Member.injectSum_inl [Member E G] [Member F H]:
  @Member.inject (E +' F) (G +' H) MemberSum _ (Sum.inl e) =
    Sum.inl (Member.inject _ e) := rfl

@[simp] theorem Member.injectSum_inr [Member E G] [Member F H]:
  @Member.inject (E +' F) (G +' H) MemberSum _ (Sum.inr e) =
    Sum.inr (Member.inject _ e) := rfl

-- Interpretatin identities

@[simp] theorem Fitree.interp_ret:
  Fitree.interp h (Fitree.ret r) = Fitree.ret r := rfl

@[simp] theorem Fitree.interp_Ret:
  Fitree.interp h (Fitree.Ret r) = Fitree.ret r := rfl

@[simp] theorem Fitree.interp_Vis:
  Fitree.interp h (Fitree.Vis e k) =
  Fitree.bind (h _ e) (fun x => Fitree.interp h (k x)) := rfl

@[simp] theorem Fitree.interp'_ret:
  @Fitree.interp' E F h _ (Fitree.ret r) = Fitree.ret r := rfl

@[simp] theorem Fitree.interp'_Vis_left:
  @Fitree.interp' E F h _ (Fitree.Vis (Sum.inl e) k) =
  Fitree.bind (Fitree.translate (fun _ e => nomatch e) (h _ e))
              (fun x => Fitree.interp' h (k x)) := rfl

@[simp] theorem Fitree.interp'_Vis_right:
  @Fitree.interp' E F h _ (Fitree.Vis (Sum.inr e) k) =
  Fitree.bind (Fitree.trigger e)
              (fun x => Fitree.interp' h (k x)) := rfl

@[simp] theorem Fitree.interpState_ret:
  Fitree.interpState h (Fitree.ret r) = (fun s => Fitree.ret (r, s)) := rfl

@[simp] theorem Fitree.interpState_Vis {M S} [Monad M] (h: E ~> StateT S M):
  Fitree.interpState h (Fitree.Vis e k) =
  StateT.bind (h _ e) (fun x => Fitree.interpState h (k x)) := rfl

@[simp] theorem Fitree.interpWriter_ret:
  Fitree.interpWriter h (Fitree.ret r) = Fitree.ret (r, "") := rfl

@[simp] theorem Fitree.interpWriter_Vis {M} [Monad M] (h: E ~> WriterT M):
  Fitree.interpWriter h (Fitree.Vis e k) =
  WriterT.bind (h _ e) (fun x => Fitree.interpWriter h (k x)) := rfl

@[simp] theorem Fitree.interpOption_ret:
  Fitree.interpOption h (Fitree.ret r) = Fitree.ret (some r) := rfl

@[simp] theorem Fitree.interpOption_Vis {M} [Monad M] (h: E ~> OptionT M):
  Fitree.interpOption h (Fitree.Vis e k) =
  OptionT.bind (h _ e) (fun x => Fitree.interpOption h (k x)) := rfl

@[simp] theorem Fitree.interpExcept_ret:
  Fitree.interpExcept h (Fitree.ret r) = Fitree.ret (.ok r) := rfl

@[simp] theorem Fitree.interpExcept_Vis {M ε} [Monad M] (h: E ~> ExceptT ε M):
  Fitree.interpExcept h (Fitree.Vis e k) =
  ExceptT.bind (h _ e) (fun x => Fitree.interpExcept h (k x)) := rfl

-- We don't assume [LawfulMonad M] so we can't simplify the continuation. But
-- when it's an ITree the other simp lemmas will do it anyway.
@[simp] theorem Fitree.interp_trigger [Member E F] [Monad M] (e: E T):
  Fitree.interp (M := M) (E := F) h (Fitree.trigger e) =
  Bind.bind (h _ (Member.inject _ e)) (fun x => pure x) := rfl

@[simp] theorem Fitree.interp'_trigger_left (e: E R):
  @Fitree.interp' E F h _ (@Fitree.trigger (E +' F) _ _ MemberId (Sum.inl e)) =
  Fitree.bind
    (Fitree.translate (fun _ e => nomatch e) (h _ (Member.inject _ e)))
    (fun x => pure x) := rfl

@[simp] theorem Fitree.interp'_trigger_right [Member G F]:
  @Fitree.interp' E F h _ (@Fitree.trigger (E +' G) (E +' F) _ _ (Sum.inr e)) =
  Fitree.trigger e := rfl

-- The following theorems are only applied manually

theorem Fitree.run_bind {T R} (t: Fitree Void1 T) (k: T → Fitree Void1 R):
    run (bind t k) = run (k (run t)) :=
  match t with
  | Ret _ => rfl
  | Vis e _ => nomatch e

theorem Fitree.interp_bind:
    Fitree.interp h (Fitree.bind t k) =
    Fitree.bind (Fitree.interp h t) (fun x => Fitree.interp h (k x)) := by
  induction t with
  | Ret _ => rfl
  | Vis _ _ ih => simp [bind, ih]

theorem Fitree.interp'_bind:
    Fitree.interp' h (Fitree.bind t k) =
    Fitree.bind (Fitree.interp' h t) (fun x => Fitree.interp' h (k x)) := by
  simp [interp', interp_bind]

-- Specialized interp_bind lemmas that unfold the monadic structure and expose
-- the Fitree.bind directly rather than the monadic Bind.bind

theorem Fitree.interpState_bind (h: E ~> StateT S (Fitree F)) (t: Fitree E R):
    Fitree.interpState h (Fitree.bind t k) s =
    Fitree.bind (Fitree.interpState h t s)
      (fun (x,s') => Fitree.interpState h (k x) s') := by
  revert s
  induction t with
  | Ret _ => intros s; rfl
  | Vis _ _ ih =>
    simp [interpState] at *
    simp [interp, Bind.bind, StateT.bind]
    simp [ih]

example {F R}: WriterT (Fitree F) R = Fitree F (R × String) := by
  simp [WriterT]

theorem Fitree.interpWriter_bind (h: E ~> WriterT (Fitree F))
  (t: Fitree E T) (k: T → Fitree E R):
    Fitree.interpWriter h (Fitree.bind t k) =
    Fitree.bind (Fitree.interpWriter h t) fun (x,s₁) =>
      Fitree.bind (Fitree.interpWriter h (k x)) fun (y,s₂) =>
        Fitree.ret (y,s₁++s₂) := by
  induction t with
  | Ret _ =>
      simp [bind, interpWriter]
      have h₁: forall x, "" ++ x = x := by
        simp [HAppend.hAppend, Append.append, String.append]
        simp [List.nil_append]
      simp [h₁]
      have h₂: forall (α β: Type) (x: α × β), (x.fst, x.snd) = x := by simp
      simp [h₂]
  | Vis _ _ ih =>
      simp [interpWriter] at *
      simp [interp, Bind.bind, WriterT.bindCont, WriterT.mk]
      have h: forall (x y z: String), x ++ (y ++ z) = x ++ y ++ z := by
        simp [HAppend.hAppend, Append.append, String.append]
        simp [List.append_assoc]
      simp [ih, h]

theorem Fitree.interpOption_bind (h: E ~> OptionT (Fitree F))
  (t: Fitree E T) (k: T → Fitree E R):
    Fitree.interpOption h (Fitree.bind t k) =
    Fitree.bind (Fitree.interpOption h t) fun x? =>
      match x? with
      | some x => Fitree.interpOption h (k x)
      | none => Fitree.ret none := by
  induction t with
  | Ret _ => rfl
  | Vis _ _ ih =>
      simp [interpOption] at *
      simp [interp, bind, Bind.bind, OptionT.bind, OptionT.mk]
      -- I can't get a bind (match) → match (bind) theorem to rewrite, so...
      have fequal2 α β (f g: α → β) x y: f = g → x = y → f x = g y :=
        fun h₁ h₂ => by simp [h₁, h₂]
      apply fequal2; rfl; funext x
      cases x <;> simp [ih]

theorem Fitree.interpExcept_bind (h: E ~> ExceptT ε (Fitree F))
  (t: Fitree E T) (k: T → Fitree E R):
    Fitree.interpExcept h (Fitree.bind t k) =
    Fitree.bind (Fitree.interpExcept h t) fun x? =>
      match x? with
      | .error ε => Fitree.ret (.error ε)
      | .ok x => Fitree.interpExcept h (k x) := by
  induction t with
  | Ret _ => rfl
  | Vis _ _ ih =>
      simp [interpExcept] at *
      simp [interp, bind, Bind.bind]
      simp [ExceptT.bind, ExceptT.mk, ExceptT.bindCont]
      -- See above
      have fequal2 α β (f g: α → β) x y: f = g → x = y → f x = g y :=
        fun h₁ h₂ => by simp [h₁, h₂]
      apply fequal2; rfl; funext x
      cases x <;> simp [ih]

-- This theorem has the drawback of hiding the continuation of `bind` into the
-- `Vis` node, which blocks other theorems like `Fitree.bind_bind`.
theorem Fitree.bind_trigger [Member E F] (e: E T) (k: T → Fitree F R):
  Fitree.bind (Fitree.trigger e) k = Fitree.Vis (Member.inject _ e) k := rfl

/-
### Other properties
-/

inductive Fitree.noEventL {E F R}: Fitree (E +' F) R → Prop :=
  | Ret r: noEventL (Ret r)
  | Vis f k: (∀ t, noEventL (k t)) → noEventL (Vis (Sum.inr f) k)

/-
### Automation tools
-/

/- Rewriting tactics `simp_itree` and `dsimp_itree` -/

open Lean Elab.Tactic Parser.Tactic

def toSimpLemma (name: Name): Syntax :=
  mkNode `Lean.Parser.Tactic.simpLemma #[mkNullNode, mkNullNode, mkIdent name]

def tacticSimpItree (definitional: Bool): TacticM Unit := do
  -- TODO: Also handle .lemmaNames, not just unfolding!
  let lemmas := (← SimpItreeExtension.getTheorems).toUnfold.fold
    (init := #[]) (fun acc n => acc.push (toSimpLemma n))
  let others := [
    ``Fitree.liftHandler, ``Member.inject,
    ``StateT.bind, ``StateT.pure, ``StateT.lift,
    ``OptionT.bind, ``OptionT.pure, ``OptionT.mk, ``OptionT.lift,
    ``ExceptT.pure, ``ExceptT.mk,
    ``bind, ``pure, ``cast_eq, ``Eq.mpr].map toSimpLemma
  let fullSet :=
    (lemmas.reverse ++ others).toList.intersperse (mkAtom ",") |>.toArray
  if definitional then
    evalTactic $ ← `(tactic|dsimp [$(⟨fullSet⟩),*])
  else
    evalTactic $ ← `(tactic|simp [$(⟨fullSet⟩),*])

elab "simp_itree":  tactic => tacticSimpItree false
elab "dsimp_itree": tactic => tacticSimpItree true


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.meta.default
import Mathlib.Lean3Lib.init.data.sigma.lex
import Mathlib.Lean3Lib.init.data.nat.lemmas
import Mathlib.Lean3Lib.init.data.list.instances
import Mathlib.Lean3Lib.init.data.list.qsort

universes u v

namespace Mathlib

/- TODO(Leo): move this lemma, or delete it after we add algebraic normalizer. -/

theorem nat.lt_add_of_zero_lt_left (a : ℕ) (b : ℕ) (h : 0 < b) : a < a + b :=
  (fun (this : a + 0 < a + b) => this) (nat.add_lt_add_left h a)

/- TODO(Leo): move this lemma, or delete it after we add algebraic normalizer. -/

theorem nat.zero_lt_one_add (a : ℕ) : 0 < 1 + a := sorry

/- TODO(Leo): move this lemma, or delete it after we add algebraic normalizer. -/

theorem nat.lt_add_right (a : ℕ) (b : ℕ) (c : ℕ) : a < b → a < b + c :=
  fun (h : a < b) => lt_of_lt_of_le h (nat.le_add_right b c)

/- TODO(Leo): move this lemma, or delete it after we add algebraic normalizer. -/

theorem nat.lt_add_left (a : ℕ) (b : ℕ) (c : ℕ) : a < b → a < c + b :=
  fun (h : a < b) => lt_of_lt_of_le h (nat.le_add_left b c)

protected def psum.alt.sizeof {α : Type u} {β : Type v} [SizeOf α] [SizeOf β] : psum α β → ℕ :=
  sorry

protected def psum.has_sizeof_alt (α : Type u) (β : Type v) [SizeOf α] [SizeOf β] :
    SizeOf (psum α β) :=
  { sizeOf := psum.alt.sizeof }

end Mathlib


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import control.applicative
import data.list.forall2
import data.set.functor

/-!
# Traversable instances

This file provides instances of `traversable` for types from the core library: `option`, `list` and
`sum`.
-/

universes u v

section option

open functor

variables {F G : Type u → Type u}
variables [applicative F] [applicative G]
variables [is_lawful_applicative F] [is_lawful_applicative G]

lemma option.id_traverse {α} (x : option α) : option.traverse id.mk x = x :=
by cases x; refl

@[nolint unused_arguments]
lemma option.comp_traverse {α β γ} (f : β → F γ) (g : α → G β) (x : option α) :
  option.traverse (comp.mk ∘ (<$>) f ∘ g) x =
  comp.mk (option.traverse f <$> option.traverse g x) :=
by cases x; simp! with functor_norm; refl

lemma option.traverse_eq_map_id {α β} (f : α → β) (x : option α) :
  traverse (id.mk ∘ f) x = id.mk (f <$> x) :=
by cases x; refl

variable (η : applicative_transformation F G)

lemma option.naturality {α β} (f : α → F β) (x : option α) :
  η (option.traverse f x) = option.traverse (@η _ ∘ f) x :=
by cases x with x; simp! [*] with functor_norm

end option

instance : is_lawful_traversable option :=
{ id_traverse := @option.id_traverse,
  comp_traverse := @option.comp_traverse,
  traverse_eq_map_id := @option.traverse_eq_map_id,
  naturality := @option.naturality,
  .. option.is_lawful_monad }

namespace list

variables {F G : Type u → Type u}
variables [applicative F] [applicative G]

section
variables [is_lawful_applicative F] [is_lawful_applicative G]

open applicative functor list

protected lemma id_traverse {α} (xs : list α) :
  list.traverse id.mk xs = xs :=
by induction xs; simp! * with functor_norm; refl

@[nolint unused_arguments]
protected lemma comp_traverse {α β γ} (f : β → F γ) (g : α → G β) (x : list α) :
  list.traverse (comp.mk ∘ (<$>) f ∘ g) x =
  comp.mk (list.traverse f <$> list.traverse g x) :=
by induction x; simp! * with functor_norm; refl

protected lemma traverse_eq_map_id {α β} (f : α → β) (x : list α) :
  list.traverse (id.mk ∘ f) x = id.mk (f <$> x) :=
by induction x; simp! * with functor_norm; refl

variable (η : applicative_transformation F G)

protected lemma naturality {α β} (f : α → F β) (x : list α) :
  η (list.traverse f x) = list.traverse (@η _ ∘ f) x :=
by induction x; simp! * with functor_norm
open nat

instance : is_lawful_traversable.{u} list :=
{ id_traverse := @list.id_traverse,
  comp_traverse := @list.comp_traverse,
  traverse_eq_map_id := @list.traverse_eq_map_id,
  naturality := @list.naturality,
  .. list.is_lawful_monad }
end

section traverse
variables {α' β' : Type u} (f : α' → F β')

@[simp] lemma traverse_nil : traverse f ([] : list α') = (pure [] : F (list β')) := rfl

@[simp] lemma traverse_cons (a : α') (l : list α') :
  traverse f (a :: l) = (::) <$> f a <*> traverse f l := rfl

variables [is_lawful_applicative F]

@[simp] lemma traverse_append :
  ∀ (as bs : list α'), traverse f (as ++ bs) = (++) <$> traverse f as <*> traverse f bs
| [] bs :=
  have has_append.append ([] : list β') = id, by funext; refl,
  by simp [this] with functor_norm
| (a :: as) bs := by simp [traverse_append as bs] with functor_norm; congr

lemma mem_traverse {f : α' → set β'} :
  ∀(l : list α') (n : list β'), n ∈ traverse f l ↔ forall₂ (λb a, b ∈ f a) n l
| []      []      := by simp
| (a::as) []      := by simp
| []      (b::bs) := by simp
| (a::as) (b::bs) := by simp [mem_traverse as bs]

end traverse

end list

namespace sum

section traverse
variables {σ : Type u}
variables {F G : Type u → Type u}
variables [applicative F] [applicative G]

open applicative functor
open list (cons)

protected lemma traverse_map {α β γ : Type u} (g : α → β) (f : β → G γ) (x : σ ⊕ α) :
  sum.traverse f (g <$> x) = sum.traverse (f ∘ g) x :=
by cases x; simp [sum.traverse, id_map] with functor_norm; refl

variables [is_lawful_applicative F] [is_lawful_applicative G]

protected lemma id_traverse {σ α} (x : σ ⊕ α) : sum.traverse id.mk x = x :=
by cases x; refl

@[nolint unused_arguments]
protected lemma comp_traverse {α β γ} (f : β → F γ) (g : α → G β) (x : σ ⊕ α) :
  sum.traverse (comp.mk ∘ (<$>) f ∘ g) x =
  comp.mk (sum.traverse f <$> sum.traverse g x) :=
by cases x; simp! [sum.traverse,map_id] with functor_norm; refl

protected lemma traverse_eq_map_id {α β} (f : α → β) (x : σ ⊕ α) :
  sum.traverse (id.mk ∘ f) x = id.mk (f <$> x) :=
by induction x; simp! * with functor_norm; refl

protected lemma map_traverse {α β γ} (g : α → G β) (f : β → γ) (x : σ ⊕ α) :
  (<$>) f <$> sum.traverse g x = sum.traverse ((<$>) f ∘ g) x :=
by cases x; simp [sum.traverse, id_map] with functor_norm; congr; refl

variable (η : applicative_transformation F G)

protected lemma naturality {α β} (f : α → F β) (x : σ ⊕ α) :
  η (sum.traverse f x) = sum.traverse (@η _ ∘ f) x :=
by cases x; simp! [sum.traverse] with functor_norm

end traverse

instance {σ : Type u} : is_lawful_traversable.{u} (sum σ) :=
{ id_traverse := @sum.id_traverse σ,
  comp_traverse := @sum.comp_traverse σ,
  traverse_eq_map_id := @sum.traverse_eq_map_id σ,
  naturality := @sum.naturality σ,
  .. sum.is_lawful_monad }

end sum


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author(s): Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.monad.basic
import Mathlib.control.monad.cont
import Mathlib.control.monad.writer
import Mathlib.data.equiv.basic
import Mathlib.tactic.interactive
import Mathlib.PostPort

universes u₀ u₁ v₀ v₁ l u_1 u_2 u_3 u_4 u_5 u_6

namespace Mathlib

/-!
# Universe lifting for type families

Some functors such as `option` and `list` are universe polymorphic. Unlike
type polymorphism where `option α` is a function application and reasoning and
generalizations that apply to functions can be used, `option.{u}` and `option.{v}`
are not one function applied to two universe names but one polymorphic definition
instantiated twice. This means that whatever works on `option.{u}` is hard
to transport over to `option.{v}`. `uliftable` is an attempt at improving the situation.

`uliftable option.{u} option.{v}` gives us a generic and composable way to use
`option.{u}` in a context that requires `option.{v}`. It is often used in tandem with
`ulift` but the two are purposefully decoupled.

## Main definitions
  * `uliftable` class

## Tags

universe polymorphism functor

-/

/-- Given a universe polymorphic type family `M.{u} : Type u₁ → Type
u₂`, this class convert between instantiations, from
`M.{u} : Type u₁ → Type u₂` to `M.{v} : Type v₁ → Type v₂` and back -/
class uliftable (f : Type u₀ → Type u₁) (g : Type v₀ → Type v₁)
where
  congr : {α : Type u₀} → {β : Type v₀} → α ≃ β → f α ≃ g β

namespace uliftable

/-- The most common practical use `uliftable` (together with `up`), this function takes
`x : M.{u} α` and lifts it to M.{max u v} (ulift.{v} α) -/
def up {f : Type u₀ → Type u₁} {g : Type (max u₀ v₀) → Type v₁} [uliftable f g] {α : Type u₀} : f α → g (ulift α) :=
  equiv.to_fun (congr f g (equiv.symm equiv.ulift))

/-- The most common practical use of `uliftable` (together with `up`), this function takes
`x : M.{max u v} (ulift.{v} α)` and lowers it to `M.{u} α` -/
def down {f : Type u₀ → Type u₁} {g : Type (max u₀ v₀) → Type v₁} [uliftable f g] {α : Type u₀} : g (ulift α) → f α :=
  equiv.inv_fun (congr f g (equiv.symm equiv.ulift))

/-- convenient shortcut to avoid manipulating `ulift` -/
def adapt_up (F : Type v₀ → Type v₁) (G : Type (max v₀ u₀) → Type u₁) [uliftable F G] [Monad G] {α : Type v₀} {β : Type (max v₀ u₀)} (x : F α) (f : α → G β) : G β :=
  up x >>= f ∘ ulift.down

/-- convenient shortcut to avoid manipulating `ulift` -/
def adapt_down {F : Type (max u₀ v₀) → Type u₁} {G : Type v₀ → Type v₁} [L : uliftable G F] [Monad F] {α : Type (max u₀ v₀)} {β : Type v₀} (x : F α) (f : α → G β) : G β :=
  down (x >>= up ∘ f)

/-- map function that moves up universes -/
def up_map {F : Type u₀ → Type u₁} {G : Type (max u₀ v₀) → Type v₁} [inst : uliftable F G] [Functor G] {α : Type u₀} {β : Type (max u₀ v₀)} (f : α → β) (x : F α) : G β :=
  (f ∘ ulift.down) <$> up x

/-- map function that moves down universes -/
def down_map {F : Type (max u₀ v₀) → Type u₁} {G : Type → Type v₁} [inst : uliftable G F] [Functor F] {α : Type (max u₀ v₀)} {β : Type} (f : α → β) (x : F α) : G β :=
  down ((ulift.up ∘ f) <$> x)

@[simp] theorem up_down {f : Type u₀ → Type u₁} {g : Type (max u₀ v₀) → Type v₁} [uliftable f g] {α : Type u₀} (x : g (ulift α)) : up (down x) = x :=
  equiv.right_inv (congr f g (equiv.symm equiv.ulift)) x

@[simp] theorem down_up {f : Type u₀ → Type u₁} {g : Type (max u₀ v₀) → Type v₁} [uliftable f g] {α : Type u₀} (x : f α) : down (up x) = x :=
  equiv.left_inv (congr f g (equiv.symm equiv.ulift)) x

end uliftable

protected instance id.uliftable : uliftable id id :=
  uliftable.mk fun (α : Type u_1) (β : Type u_2) (F : α ≃ β) => F

/-- for specific state types, this function helps to create a uliftable instance -/
def state_t.uliftable' {s : Type u₀} {s' : Type u₁} {m : Type u₀ → Type v₀} {m' : Type u₁ → Type v₁} [uliftable m m'] (F : s ≃ s') : uliftable (state_t s m) (state_t s' m') :=
  uliftable.mk
    fun (α : Type u₀) (β : Type u₁) (G : α ≃ β) =>
      state_t.equiv (equiv.Pi_congr F fun (_x : s) => uliftable.congr m m' (equiv.prod_congr G F))

protected instance state_t.uliftable {s : Type u_1} {m : Type u_1 → Type u_2} {m' : Type (max u_1 u_3) → Type u_4} [uliftable m m'] : uliftable (state_t s m) (state_t (ulift s) m') :=
  state_t.uliftable' (equiv.symm equiv.ulift)

/-- for specific reader monads, this function helps to create a uliftable instance -/
def reader_t.uliftable' {s : Type u_1} {s' : Type u_2} {m : Type u_1 → Type u_3} {m' : Type u_2 → Type u_4} [uliftable m m'] (F : s ≃ s') : uliftable (reader_t s m) (reader_t s' m') :=
  uliftable.mk
    fun (α : Type u_1) (β : Type u_2) (G : α ≃ β) =>
      reader_t.equiv (equiv.Pi_congr F fun (_x : s) => uliftable.congr m m' G)

protected instance reader_t.uliftable {s : Type u_1} {m : Type u_1 → Type u_2} {m' : Type (max u_1 u_3) → Type u_4} [uliftable m m'] : uliftable (reader_t s m) (reader_t (ulift s) m') :=
  reader_t.uliftable' (equiv.symm equiv.ulift)

/-- for specific continuation passing monads, this function helps to create a uliftable instance -/
def cont_t.uliftable' {r : Type u_1} {r' : Type u_2} {m : Type u_1 → Type u_3} {m' : Type u_2 → Type u_4} [uliftable m m'] (F : r ≃ r') : uliftable (cont_t r m) (cont_t r' m') :=
  uliftable.mk fun (α : Type u_1) (β : Type u_2) => cont_t.equiv (uliftable.congr m m' F)

protected instance cont_t.uliftable {s : Type u_1} {m : Type u_1 → Type u_2} {m' : Type (max u_1 u_3) → Type u_4} [uliftable m m'] : uliftable (cont_t s m) (cont_t (ulift s) m') :=
  cont_t.uliftable' (equiv.symm equiv.ulift)

/-- for specific writer monads, this function helps to create a uliftable instance -/
def writer_t.uliftable' {w : Type (max u_1 u_2)} {w' : Type (max u_3 u_4)} {m : Type (max u_1 u_2) → Type u_5} {m' : Type (max u_3 u_4) → Type u_6} [uliftable m m'] (F : w ≃ w') : uliftable (writer_t w m) (writer_t w' m') :=
  uliftable.mk
    fun (α : Type (max u_1 u_2)) (β : Type (max u_3 u_4)) (G : α ≃ β) =>
      writer_t.equiv (uliftable.congr m m' (equiv.prod_congr G F))

protected instance writer_t.uliftable {s : Type (max u_1 u_2)} {m : Type (max u_1 u_2) → Type u_3} {m' : Type (max (max u_1 u_2) u_4) → Type u_5} [uliftable m m'] : uliftable (writer_t s m) (writer_t (ulift s) m') :=
  writer_t.uliftable' (equiv.symm equiv.ulift)


def f : Prop → Prop := id

class Foo (foo : Prop → Prop) where
  l : x → foo x

instance : Foo f where
  l := by simp_all [f]

theorem test' (h : x = True) : f x := by
  have _ := True
  apply Foo.l  -- `?foo ?x =?= [mdata noImplicitLambda:1 f x]`
  simp [h]