-- TODO a tactic for resolving statements in integral domain rings

-- This tactic should work as follows:
-- 1. Find all equality statements in the Euclidean ring in the statements (and goal)
-- 2. Break down either side of these equalities into a tree of add and mul operations (do not break down sums or prods)
-- 3. Identify all atoms of R from these, and put these equations in ring normal form
-- 4. Mutually simplify the equations by gaussian elimination. That is - check if subtracting off any statement equation from any other, or any statement from the goal,  "simplifies it" in terms of leaving less added terms. If so, perform this subtraction and resimplify. Repeat until we get through all pairs without a simplification.
-- 5. Check if any atom can be factored out of an equation, with zero on the other side. If so, simplify this to the disjunction of this atom being zero or the other factor being zero. Split on this disjunction, and repeat from step 4 on both sides of the split.

-- This is related to the Nullstellensatz. Specifically [Buchberger's Algorithm](https://en.wikipedia.org/wiki/Buchberger%27s_algorithm) is one way of doing what I do here. Not sure yet what the relation is - probably Buchberger is more general, but more time complex? See also the coq tactic [nsatz](https://coq.inria.fr/refman/addendum/nsatz.html).

-- What is the ["effective nullstellensatz"](https://en.wikipedia.org/wiki/Hilbert%27s_Nullstellensatz#Effective_Nullstellensatz) of these problems

import data.mv_polynomial.basic
import .general_lemmas.mv_X_mul
import .general_lemmas.single_antidiagonal
import tactic.abel
import .attributes

open tactic

namespace tactic

namespace interactive
open interactive interactive.types expr

setup_tactic_parser

meta def my_simp_only (hs : parse simp_arg_list) (attr_names : parse with_ident_list)
              (locat : parse location) (cfg : simp_config_ext := {}) : tactic unit :=
propagate_tags $
do lms ← simp_core cfg.to_simp_config cfg.discharger tt hs attr_names locat,
  if cfg.trace_lemmas then trace (↑"Try this: simp only " ++ to_fmt lms.to_list) else skip

meta def get_the_name : expr → option name
| (local_const unique pretty bi type) := some pretty
| _ := none

/-- Returns a list of names of propositions in the local context which are either equalities or
have some logical definition -/
meta def context_prop_name_getter : tactic (list name) := do
  ctx <- local_context,
  ctx' <- ctx.mfilter (λ e, do
    tp <- infer_type e,
    return (option.is_some (is_eq tp)
            || option.is_some (is_not tp)
            || option.is_some (is_ne tp)
            || option.is_some (is_or tp))
  ),
  let names := ctx'.filter_map get_the_name in do
  -- trace ctx',
  return names

/-- For a name in the local context, simplify at it with found_zero, and if that is successful, simplifies again with integral_domain_simp. -/
meta def simplify_at_name (nm : name) : tactic unit :=
  if nm = `found_zero then do skip else do
  found_zero_expr <- get_local `found_zero,
  used_set <- simp_core {fail_if_unchanged := ff} (failed) tt [simp_arg_type.expr (pexpr.of_expr found_zero_expr)] [] (loc.ns [some nm]),
  match name_set.empty used_set with
  | tt := skip
  | ff := do attr_used_set <- simp_core {fail_if_unchanged := ff} (failed) tt [] [`integral_domain_simp] (loc.ns [some nm]), skip
  end

/-- For a name nmat in the local context, simplify at it with nmwith,
and if that is successful, simplify again at nmat with integral_domain_simp.
Never fails, but returns tt if the simplification changed something -/
meta def simplify_at_with (nmat nmwith : name) : tactic bool :=
  if nmat = nmwith then do return ff else do
  nmwith_expr <- get_local nmwith,
  used_set <- simp_core {fail_if_unchanged := ff} (failed) tt [simp_arg_type.expr (pexpr.of_expr nmwith_expr)] [] (loc.ns [some nmat]),
  match name_set.empty used_set with
  | tt := return ff
  | ff := do
    attr_used_set <- simp_core {fail_if_unchanged := ff} (failed) tt [] [`integral_domain_simp] (loc.ns [some nmat]),
    return attr_used_set.empty
  end

/-- For each name in the local context, simplifies with found zero, and if that is successful, simplifies again with integral_domain_simp. -/
meta def simplify_everywhere : tactic unit := do
  names <- context_prop_name_getter,
  names.mmap' simplify_at_name,
  -- Simp the target
  try `[simp only [found_zero] with integral_domain_simp]

meta def mutually_simplify_aux : list name -> list name -> tactic unit
| [] _ := skip
| (nm_with::to_simplify_withs) other := do
  -- simplify the ones we will simplify with in the future
  to_simplify_withs.mmap' (λ a, simplify_at_with a nm_with),
  -- Simplify the others, and if they change, remove them from other and add to future
  other_success_labels <- other.mmap (λ a, simplify_at_with a nm_with),
  let others_changed := list.reduce_option (list.zip_with
                            (λ nm b, match b with
                              | tt := (some nm : option name)
                              | ff := none end)
                            other other_success_labels),
  let others_unchanged := list.reduce_option (list.zip_with
                            (λ nm b, match b with
                              | tt := none
                              | ff := (some nm : option name)  end)
                            other other_success_labels),
  let new_to_simplify_with := list.append to_simplify_withs others_changed,
  mutually_simplify_aux new_to_simplify_with others_unchanged

meta def mutually_simplify : tactic unit := do
  names <- context_prop_name_getter,
  mutually_simplify_aux names []

/-- Assuming nm is the only changed name, simplify with that -/
meta def mutually_simplify_one (nm : name) : tactic unit := do
  names <- context_prop_name_getter,
  let names' := list.erase names nm,
  mutually_simplify_aux (nm::[]) names

end interactive

-- Adapted from Mario's example
meta def integral_domain_tactic : tactic unit := do
  -- trace "\nCall to integral_domain_tactic",
  -- trace_state, -- printf debugging
  `[my_simp_only [] with integral_domain_simp
    at * {fail_if_unchanged := ff}],
  try `[cases_type* true false],
  _::_ ← get_goals | skip,
  cases_success <- try_core `[cases ‹_ ∨ _› with nm nm],
  match cases_success with
  | some _ := all_goals' `[simp only [nm] at *, done <|> id { integral_domain_tactic }]
  -- TODO, I need to change this so that,
  -- if rw found_zero fails the program stops and doesn't clear found_zero.
  -- for now I remove the clear nm part
  | none := skip
  end

-- Broken version that tries to only simplify things when we know they have changed.
meta def integral_domain_tactic_v2 : tactic unit := do
  trace "\nCall to integral_domain_tactic_v2",
  -- trace_state, -- printf debugging
  try `[cases_type* true false],
  _::_ ← get_goals | skip,
  try `[clear found_zero],
  cases_success <- try_core `[cases ‹_ ∨ _› with found_zero found_zero],
  match cases_success with -- simplify everywhere might produce a simplification that can further help.
  | some _ := all_goals' (do tactic.interactive.simplify_everywhere, done <|> integral_domain_tactic_v2)
  | none := skip
  end

-- Adapted from Mario's example
-- I screwed this one up and made the recursive call to integral_domain_tactic
-- instead of integral_domain_tactic_v3. Switching to _4 and leaving this for posterity.
-- _4 below seems to make this take 1 min instead of 30 min, which the amount of time
-- this has been taking the past few weeks.
-- :(
meta def integral_domain_tactic_v3 : tactic unit := do
  trace "\nCall to integral_domain_tactic_v3",
  -- trace_state, -- printf debugging
  `[my_simp_only [*] with integral_domain_simp
    at * {fail_if_unchanged := ff}],
  try `[cases_type* true false],
  _::_ ← get_goals | skip,
  try `[clear found_zero],
  cases_success <- try_core `[cases ‹_ ∨ _› with found_zero found_zero],
  match cases_success with
  | some _ := all_goals' `[done <|> id { integral_domain_tactic }]
  -- TODO, I need to change this so that,
  -- if rw found_zero fails the program stops and doesn't clear found_zero.
  -- for now I remove the clear found_zero part
  | none := skip
  end

meta def integral_domain_tactic_v4 : tactic unit := do
  trace "Call to integral_domain_tactic_v4",
  -- trace_state, -- printf debugging
  `[my_simp_only [*] with integral_domain_simp
    at * {fail_if_unchanged := ff}],
  try `[cases_type* true false],
  _::_ ← get_goals | skip,
  try `[clear found_zero],
  cases_success <- try_core `[cases ‹_ ∨ _› with found_zero found_zero],
  match cases_success with
  | some _ := all_goals' `[done <|> id { integral_domain_tactic_v4 }]
  | none := skip
  end

-- In practice this seems to be slower, perhaps the optimization is not worth the code complexity.
meta def integral_domain_tactic_v5 : tactic unit := do
  trace "Call to integral_domain_tactic_v5",
  -- trace_state, -- printf debugging
  ctx <- tactic.interactive.context_prop_name_getter,
  if `found_zero ∈ ctx then tactic.interactive.mutually_simplify_one `found_zero else skip,
  try `[cases_type* true false],
  _::_ ← get_goals | skip,
  try `[clear found_zero],
  cases_success <- try_core `[cases ‹_ ∨ _› with found_zero found_zero],
  match cases_success with
  | some _ := all_goals' `[done <|> id { integral_domain_tactic_v5 }]
  | none := skip
  end

open expr

end tactic

-- run_cmd add_interactive [`integral_domain_tactic]

section test

universes u

/-- The finite field parameter of our SNARK -/
parameters {R vars : Type u}
-- parameter [ring R]

lemma zero_eq_zero [integral_domain R] : (0 : R) = 0 ↔ true :=
begin
  simp only [eq_self_iff_true],
end

-- example [integral_domain R] (a b c d e f g h i : R) (h11 : ¬a = 0) (h12 : ¬b = 0)  (h2 : a * c = 0) (h3 : b * d = 0) (h4 : h * i = 0): c * e + f * d = h :=
-- begin
--   -- integral_domain_tactic,
--   simp only [] with integral_domain_simp
--     at * {fail_if_unchanged := ff},
--   -- integral_domain_tactic',
--   sorry,
-- end

-- example [integral_domain R] (a b c d e f g h i : R) (h11 : ¬a = 0) (h12 : ¬b = 0) (h4 : h = 0 ∨ i = 0): f * 0 = h :=
-- begin
--   simp only [] with integral_domain_simp
--     at * {fail_if_unchanged := ff},
--   cases ‹_ ∨ _› with found_zero found_zero,
--   -- tactic.context_name_getter,
--   rw found_zero at *,
--   rw found_zero at *,
--   sorry,
-- end

-- example [integral_domain R] (a b c d e f : R) (h11 : ¬a = 0) (h12 : ¬b = 0)  (h2 : a * c = 0) (h3 : b * d = 0) : c * e + f * d = 0 :=
-- begin
--   simp only [] with integral_domain_simp
--     at * {fail_if_unchanged := ff},
--   tactic.integral_domain_tactic_v3,
--   -- tactic.integral_domain_tactic,
-- end

-- example [integral_domain R] (a b c d e f g : R) (h11 : ¬a = 0) (h12 : ¬b = 0)  (h2 : a * c = 0) (h3 : b * d = 0) : c * e + f * d = g :=
-- begin
--   tactic.integral_domain_tactic,
--   sorry,
-- end

-- example [integral_domain R] (a b c d e f : R) (h11 : ¬a = 0) (h12 : ¬b = 0)  (h2 : a * c = 0) (h3 : b * d = 0) : c * e + f * d = 0 :=
-- begin
--   simp only [] with integral_domain_simp
--     at * {fail_if_unchanged := ff},
--   cases ‹_ ∨ _› with found_zero found_zero,
--   context_prop_name_getter,
--   simplify_everywhere,
--   simplify_at_name `h11,
--   simplify_at_name `h12,
--   simplify_at_name `found_zero,
--   sorry,
--   sorry,

-- end

end test

-- end


import combinatorics.simple_graph.connectivity

open_locale classical

universe u
variables {V : Type u} (G : simple_graph V)

theorem eq_of_len_zero {u v : V} (w : G.walk u v) (h : w.length = 0) : u = v :=
begin
  -- { exfalso,
  --   simp only [nat.succ_ne_zero, simple_graph.walk.length_cons] at *,
  --   exact h, }
  --easy
  sorry,
end

theorem exists_walk_of_len {u v : V} {n : ℕ} (w : G.walk u v) (h : w.length = n + 1) :
  ∃ (v' : V) (w' : G.walk u v'), (w'.length = n) ∧ (G.adj v' v) :=
begin
  -- not sure
  sorry,
end

theorem adj_of_len_one {u v : V} (w : G.walk u v) (h : w.length = 1) : G.adj u v :=
begin
  have h' := exists_walk_of_len G w h,
  rcases h' with ⟨v', w', h1, h2⟩,
  have h3 := eq_of_len_zero G w' h1,
  rw ← h3 at h2,
  assumption,
end

theorem non_eq_of_len_one {u v : V} (w : G.walk u v) (h : w.length = 1) : u ≠ v :=
begin
  -- easy
  sorry
end


import category_theory.equivalence

open category_theory

variables {C : Type*} [category C]
variables {D : Type*} [category D]

lemma equiv_reflects_mono {X Y : C} (f : X ⟶ Y) (e : C ≌ D)
  (hef : mono (e.functor.map f)) : mono f :=
-- Hint: when `e : C ≌ D`, `e.functor.map_injective` says
--   `∀ f g, e.functor.map f = e.functor.map g → f = g`
-- Hint: use `cancel_mono`.
sorry

lemma equiv_preserves_mono {X Y : C} (f : X ⟶ Y) [mono f] (e : C ≌ D) :
  mono (e.functor.map f) :=
-- Hint: if `w : f = g`, to obtain `F.map f = F.map G`,
--   you can use `have w' := congr_arg (λ k, F.map k) w`.
sorry

/-!
There are some further hints in
`hints/category_theory/exercise3/`
-/


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Scott Morrison, Adam Topaz
-/
import algebraic_topology.simplex_category
import category_theory.arrow
import category_theory.limits.functor_category
import category_theory.opposites

/-!
# Simplicial objects in a category.

A simplicial object in a category `C` is a `C`-valued presheaf on `simplex_category`.
(Similarly a cosimplicial object is functor `simplex_category ⥤ C`.)

Use the notation `X _[n]` in the `simplicial` locale to obtain the `n`-th term of a
(co)simplicial object `X`, where `n` is a natural number.

-/

open opposite
open category_theory
open category_theory.limits

universes v u

namespace category_theory

variables (C : Type u) [category.{v} C]

/-- The category of simplicial objects valued in a category `C`.
This is the category of contravariant functors from `simplex_category` to `C`. -/
@[derive category, nolint has_inhabited_instance]
def simplicial_object := simplex_category.{v}ᵒᵖ ⥤ C

namespace simplicial_object

localized
  "notation X `_[`:1000 n `]` :=
    (X : category_theory.simplicial_object _).obj (opposite.op (simplex_category.mk n))"
  in simplicial

instance {J : Type v} [small_category J] [has_limits_of_shape J C] :
  has_limits_of_shape J (simplicial_object C) := by {dsimp [simplicial_object], apply_instance}

instance [has_limits C] : has_limits (simplicial_object C) := ⟨infer_instance⟩

instance {J : Type v} [small_category J] [has_colimits_of_shape J C] :
  has_colimits_of_shape J (simplicial_object C) := by {dsimp [simplicial_object], apply_instance}

instance [has_colimits C] : has_colimits (simplicial_object C) := ⟨infer_instance⟩

variables {C} (X : simplicial_object C)

/-- Face maps for a simplicial object. -/
def δ {n} (i : fin (n+2)) : X _[n+1] ⟶ X _[n] :=
X.map (simplex_category.δ i).op

/-- Degeneracy maps for a simplicial object. -/
def σ {n} (i : fin (n+1)) : X _[n] ⟶ X _[n+1] :=
X.map (simplex_category.σ i).op

/-- Isomorphisms from identities in ℕ. -/
def eq_to_iso {n m : ℕ} (h : n = m) : X _[n] ≅ X _[m] :=
X.map_iso (eq_to_iso (by rw h))

@[simp] lemma eq_to_iso_refl {n : ℕ} (h : n = n) : X.eq_to_iso h = iso.refl _ :=
by { ext, simp [eq_to_iso], }

/-- The generic case of the first simplicial identity -/
lemma δ_comp_δ {n} {i j : fin (n+2)} (H : i ≤ j) :
  X.δ j.succ ≫ X.δ i = X.δ i.cast_succ ≫ X.δ j :=
by { dsimp [δ], simp only [←X.map_comp, ←op_comp, simplex_category.δ_comp_δ H] }

/-- The special case of the first simplicial identity -/
lemma δ_comp_δ_self {n} {i : fin (n+2)} : X.δ i.cast_succ ≫ X.δ i = X.δ i.succ ≫ X.δ i :=
by { dsimp [δ], simp only [←X.map_comp, ←op_comp, simplex_category.δ_comp_δ_self] }

/-- The second simplicial identity -/
lemma δ_comp_σ_of_le {n} {i : fin (n+2)} {j : fin (n+1)} (H : i ≤ j.cast_succ) :
  X.σ j.succ ≫ X.δ i.cast_succ = X.δ i ≫ X.σ j :=
by { dsimp [δ, σ], simp only [←X.map_comp, ←op_comp, simplex_category.δ_comp_σ_of_le H] }

/-- The first part of the third simplicial identity -/
lemma δ_comp_σ_self {n} {i : fin (n+1)} :
  X.σ i ≫ X.δ i.cast_succ = 𝟙 _ :=
begin
  dsimp [δ, σ],
  simp only [←X.map_comp, ←op_comp, simplex_category.δ_comp_σ_self, op_id, X.map_id],
end

/-- The second part of the third simplicial identity -/
lemma δ_comp_σ_succ {n} {i : fin (n+1)} :
  X.σ i ≫ X.δ i.succ = 𝟙 _ :=
begin
  dsimp [δ, σ],
  simp only [←X.map_comp, ←op_comp, simplex_category.δ_comp_σ_succ, op_id, X.map_id],
end

/-- The fourth simplicial identity -/
lemma δ_comp_σ_of_gt {n} {i : fin (n+2)} {j : fin (n+1)} (H : j.cast_succ < i) :
  X.σ j.cast_succ ≫ X.δ i.succ = X.δ i ≫ X.σ j :=
by { dsimp [δ, σ], simp only [←X.map_comp, ←op_comp, simplex_category.δ_comp_σ_of_gt H] }

/-- The fifth simplicial identity -/
lemma σ_comp_σ {n} {i j : fin (n+1)} (H : i ≤ j) :
  X.σ j ≫ X.σ i.cast_succ = X.σ i ≫ X.σ j.succ :=
by { dsimp [δ, σ], simp only [←X.map_comp, ←op_comp, simplex_category.σ_comp_σ H] }

variable (C)

/-- Functor composition induces a functor on simplicial objects. -/
@[simps]
def whiskering (D : Type*) [category.{v} D] :
  (C ⥤ D) ⥤ simplicial_object C ⥤ simplicial_object D :=
whiskering_right _ _ _

/-- Truncated simplicial objects. -/
@[derive category, nolint has_inhabited_instance]
def truncated (n : ℕ) := (simplex_category.truncated.{v} n)ᵒᵖ ⥤ C

variable {C}

namespace truncated

instance {n} {J : Type v} [small_category J] [has_limits_of_shape J C] :
  has_limits_of_shape J (simplicial_object.truncated C n) := by {dsimp [truncated], apply_instance}

instance {n} [has_limits C] : has_limits (simplicial_object.truncated C n) := ⟨infer_instance⟩

instance {n} {J : Type v} [small_category J] [has_colimits_of_shape J C] :
  has_colimits_of_shape J (simplicial_object.truncated C n) :=
by {dsimp [truncated], apply_instance}

instance {n} [has_colimits C] : has_colimits (simplicial_object.truncated C n) := ⟨infer_instance⟩

variable (C)

/-- Functor composition induces a functor on truncated simplicial objects. -/
@[simps]
def whiskering {n} (D : Type*) [category.{v} D] :
  (C ⥤ D) ⥤ truncated C n ⥤ truncated D n :=
whiskering_right _ _ _

variable {C}

end truncated

section skeleton

/-- The skeleton functor from simplicial objects to truncated simplicial objects. -/
def sk (n : ℕ) : simplicial_object C ⥤ simplicial_object.truncated C n :=
(whiskering_left _ _ _).obj simplex_category.truncated.inclusion.op

end skeleton

variable (C)

/-- The constant simplicial object is the constant functor. -/
abbreviation const : C ⥤ simplicial_object C := category_theory.functor.const _

/-- The category of augmented simplicial objects, defined as a comma category. -/
@[derive category, nolint has_inhabited_instance]
def augmented := comma (𝟭 (simplicial_object C)) (const C)

variable {C}

namespace augmented

/-- Drop the augmentation. -/
@[simps]
def drop : augmented C ⥤ simplicial_object C := comma.fst _ _

/-- The point of the augmentation. -/
@[simps]
def point : augmented C ⥤ C := comma.snd _ _

/-- The functor from augmented objects to arrows. -/
@[simps]
def to_arrow : augmented C ⥤ arrow C :=
{ obj := λ X,
  { left := (drop.obj X) _[0],
    right := (point.obj X),
    hom := X.hom.app _ },
  map := λ X Y η,
  { left := (drop.map η).app _,
    right := (point.map η),
    w' := begin
      dsimp,
      rw ← nat_trans.comp_app,
      erw η.w,
      refl,
    end } }

variable (C)

/-- Functor composition induces a functor on augmented simplicial objects. -/
@[simp]
def whiskering_obj (D : Type*) [category.{v} D] (F : C ⥤ D) :
  augmented C ⥤ augmented D :=
{ obj := λ X,
  { left := ((whiskering _ _).obj F).obj (drop.obj X),
    right := F.obj (point.obj X),
    hom := whisker_right X.hom F ≫ (functor.const_comp _ _ _).hom },
  map := λ X Y η,
  { left := whisker_right η.left _,
    right := F.map η.right,
    w' := begin
      ext,
      dsimp,
      erw [category.comp_id, category.comp_id, ← F.map_comp,
        ← F.map_comp, ← nat_trans.comp_app, η.w],
      refl,
    end } }

/-- Functor composition induces a functor on augmented simplicial objects. -/
@[simps]
def whiskering (D : Type*) [category.{v} D] :
  (C ⥤ D) ⥤ augmented C ⥤ augmented D :=
{ obj := whiskering_obj _ _,
  map := λ X Y η,
  { app := λ A,
    { left := whisker_left _ η,
      right := η.app _ } } }

variable {C}

end augmented

open_locale simplicial

/-- Aaugment a simplicial object with an object. -/
@[simps]
def augment (X : simplicial_object C) (X₀ : C) (f : X _[0] ⟶ X₀)
  (w : ∀ (i : simplex_category) (g₁ g₂ : [0] ⟶ i),
    X.map g₁.op ≫ f = X.map g₂.op ≫ f) : simplicial_object.augmented C :=
{ left := X,
  right := X₀,
  hom :=
  { app := λ i, X.map (simplex_category.const i.unop 0).op ≫ f,
    naturality' := begin
      intros i j g,
      dsimp,
      rw ← g.op_unop,
      simpa only [← X.map_comp, ← category.assoc, category.comp_id, ← op_comp] using w _ _ _,
    end } }

@[simp]
lemma augment_hom_zero (X : simplicial_object C) (X₀ : C) (f : X _[0] ⟶ X₀) (w) :
  (X.augment X₀ f w).hom.app (op [0]) = f :=
by { dsimp, erw [simplex_category.hom_zero_zero ([0].const 0), X.map_id, category.id_comp] }

end simplicial_object

/-- Cosimplicial objects. -/
@[derive category, nolint has_inhabited_instance]
def cosimplicial_object := simplex_category.{v} ⥤ C

namespace cosimplicial_object

localized
  "notation X `_[`:1000 n `]` :=
    (X : category_theory.cosimplicial_object _).obj (simplex_category.mk n)"
  in simplicial

instance {J : Type v} [small_category J] [has_limits_of_shape J C] :
  has_limits_of_shape J (cosimplicial_object C) := by {dsimp [cosimplicial_object], apply_instance}

instance [has_limits C] : has_limits (cosimplicial_object C) := ⟨infer_instance⟩

instance {J : Type v} [small_category J] [has_colimits_of_shape J C] :
  has_colimits_of_shape J (cosimplicial_object C) :=
by {dsimp [cosimplicial_object], apply_instance}

instance [has_colimits C] : has_colimits (cosimplicial_object C) := ⟨infer_instance⟩

variables {C} (X : cosimplicial_object C)

/-- Coface maps for a cosimplicial object. -/
def δ {n} (i : fin (n+2)) : X _[n] ⟶ X _[n+1] :=
X.map (simplex_category.δ i)

/-- Codegeneracy maps for a cosimplicial object. -/
def σ {n} (i : fin (n+1)) : X _[n+1] ⟶ X _[n] :=
X.map (simplex_category.σ i)

/-- Isomorphisms from identities in ℕ. -/
def eq_to_iso {n m : ℕ} (h : n = m) : X _[n] ≅ X _[m] :=
X.map_iso (eq_to_iso (by rw h))

@[simp] lemma eq_to_iso_refl {n : ℕ} (h : n = n) : X.eq_to_iso h = iso.refl _ :=
by { ext, simp [eq_to_iso], }

/-- The generic case of the first cosimplicial identity -/
lemma δ_comp_δ {n} {i j : fin (n+2)} (H : i ≤ j) :
  X.δ i ≫ X.δ j.succ = X.δ j ≫ X.δ i.cast_succ :=
by { dsimp [δ], simp only [←X.map_comp, simplex_category.δ_comp_δ H], }

/-- The special case of the first cosimplicial identity -/
lemma δ_comp_δ_self {n} {i : fin (n+2)} : X.δ i ≫ X.δ i.cast_succ = X.δ i ≫ X.δ i.succ :=
by { dsimp [δ], simp only [←X.map_comp, simplex_category.δ_comp_δ_self] }

/-- The second cosimplicial identity -/
lemma δ_comp_σ_of_le {n} {i : fin (n+2)} {j : fin (n+1)} (H : i ≤ j.cast_succ) :
  X.δ i.cast_succ ≫ X.σ j.succ = X.σ j ≫ X.δ i :=
by { dsimp [δ, σ], simp only [←X.map_comp, simplex_category.δ_comp_σ_of_le H] }

/-- The first part of the third cosimplicial identity -/
lemma δ_comp_σ_self {n} {i : fin (n+1)} :
  X.δ i.cast_succ ≫ X.σ i = 𝟙 _ :=
begin
  dsimp [δ, σ],
  simp only [←X.map_comp, simplex_category.δ_comp_σ_self, X.map_id],
end

/-- The second part of the third cosimplicial identity -/
lemma δ_comp_σ_succ {n} {i : fin (n+1)} :
  X.δ i.succ ≫ X.σ i = 𝟙 _ :=
begin
  dsimp [δ, σ],
  simp only [←X.map_comp, simplex_category.δ_comp_σ_succ, X.map_id],
end

/-- The fourth cosimplicial identity -/
lemma δ_comp_σ_of_gt {n} {i : fin (n+2)} {j : fin (n+1)} (H : j.cast_succ < i) :
  X.δ i.succ ≫ X.σ j.cast_succ = X.σ j ≫ X.δ i :=
by { dsimp [δ, σ], simp only [←X.map_comp, simplex_category.δ_comp_σ_of_gt H] }

/-- The fifth cosimplicial identity -/
lemma σ_comp_σ {n} {i j : fin (n+1)} (H : i ≤ j) :
  X.σ i.cast_succ ≫ X.σ j = X.σ j.succ ≫ X.σ i :=
by { dsimp [δ, σ], simp only [←X.map_comp, simplex_category.σ_comp_σ H] }

variable (C)

/-- Functor composition induces a functor on cosimplicial objects. -/
@[simps]
def whiskering (D : Type*) [category.{v} D] :
  (C ⥤ D) ⥤ cosimplicial_object C ⥤ cosimplicial_object D :=
whiskering_right _ _ _

/-- Truncated cosimplicial objects. -/
@[derive category, nolint has_inhabited_instance]
def truncated (n : ℕ) := simplex_category.truncated.{v} n ⥤ C

variable {C}

namespace truncated

instance {n} {J : Type v} [small_category J] [has_limits_of_shape J C] :
  has_limits_of_shape J (cosimplicial_object.truncated C n) :=
by {dsimp [truncated], apply_instance}

instance {n} [has_limits C] : has_limits (cosimplicial_object.truncated C n) := ⟨infer_instance⟩

instance {n} {J : Type v} [small_category J] [has_colimits_of_shape J C] :
  has_colimits_of_shape J (cosimplicial_object.truncated C n) :=
by {dsimp [truncated], apply_instance}

instance {n} [has_colimits C] : has_colimits (cosimplicial_object.truncated C n) := ⟨infer_instance⟩

variable (C)

/-- Functor composition induces a functor on truncated cosimplicial objects. -/
@[simps]
def whiskering {n} (D : Type*) [category.{v} D] :
  (C ⥤ D) ⥤ truncated C n ⥤ truncated D n :=
whiskering_right _ _ _

variable {C}

end truncated

section skeleton

/-- The skeleton functor from cosimplicial objects to truncated cosimplicial objects. -/
def sk (n : ℕ) : cosimplicial_object C ⥤ cosimplicial_object.truncated C n :=
(whiskering_left _ _ _).obj simplex_category.truncated.inclusion

end skeleton

variable (C)

/-- The constant cosimplicial object. -/
abbreviation const : C ⥤ cosimplicial_object C := category_theory.functor.const _

/-- Augmented cosimplicial objects. -/
@[derive category, nolint has_inhabited_instance]
def augmented := comma (const C) (𝟭 (cosimplicial_object C))

variable {C}

namespace augmented

/-- Drop the augmentation. -/
@[simps]
def drop : augmented C ⥤ cosimplicial_object C := comma.snd _ _

/-- The point of the augmentation. -/
@[simps]
def point : augmented C ⥤ C := comma.fst _ _

/-- The functor from augmented objects to arrows. -/
@[simps]
def to_arrow : augmented C ⥤ arrow C :=
{ obj := λ X,
  { left := (point.obj X),
    right := (drop.obj X) _[0],
    hom := X.hom.app _ },
  map := λ X Y η,
  { left := (point.map η),
    right := (drop.map η).app _,
    w' := begin
      dsimp,
      rw ← nat_trans.comp_app,
      erw ← η.w,
      refl,
    end } }

variable (C)

/-- Functor composition induces a functor on augmented cosimplicial objects. -/
@[simp]
def whiskering_obj (D : Type*) [category.{v} D] (F : C ⥤ D) :
  augmented C ⥤ augmented D :=
{ obj := λ X,
  { left := F.obj (point.obj X),
    right := ((whiskering _ _).obj F).obj (drop.obj X),
    hom := (functor.const_comp _ _ _).inv ≫ whisker_right X.hom F },
  map := λ X Y η,
  { left := F.map η.left,
    right := whisker_right η.right _,
    w' := begin
      ext,
      dsimp,
      erw [category.id_comp, category.id_comp, ← F.map_comp,
        ← F.map_comp, ← nat_trans.comp_app, ← η.w],
      refl,
    end } }

/-- Functor composition induces a functor on augmented cosimplicial objects. -/
@[simps]
def whiskering (D : Type*) [category.{v} D] :
  (C ⥤ D) ⥤ augmented C ⥤ augmented D :=
{ obj := whiskering_obj _ _,
  map := λ X Y η,
  { app := λ A,
    { left := η.app _,
      right := whisker_left _ η } } }

variable {C}

end augmented

open_locale simplicial

/-- Augment a cosimplicial object with an object. -/
@[simps]
def augment (X : cosimplicial_object C) (X₀ : C) (f : X₀ ⟶ X.obj [0])
  (w : ∀ (i : simplex_category) (g₁ g₂ : [0] ⟶ i),
    f ≫ X.map g₁ = f ≫ X.map g₂) : cosimplicial_object.augmented C :=
{ left := X₀,
  right := X,
  hom :=
  { app := λ i, f ≫ X.map (simplex_category.const i 0),
  naturality' := begin
    intros i j g,
    dsimp,
    simpa [← X.map_comp] using w _ _ _,
  end } }

@[simp]
lemma augment_hom_zero (X : cosimplicial_object C) (X₀ : C) (f : X₀ ⟶ X.obj [0]) (w) :
  (X.augment X₀ f w).hom.app [0] = f :=
by { dsimp, rw [simplex_category.hom_zero_zero ([0].const 0), X.map_id, category.comp_id] }

end cosimplicial_object

/-- The anti-equivalence between simplicial objects and cosimplicial objects. -/
@[simps]
def simplicial_cosimplicial_equiv : (simplicial_object C)ᵒᵖ ≌ (cosimplicial_object Cᵒᵖ) :=
functor.left_op_right_op_equiv _ _

variable {C}

/-- Construct an augmented cosimplicial object in the opposite
category from an augmented simplicial object. -/
@[simps]
def simplicial_object.augmented.right_op (X : simplicial_object.augmented C) :
  cosimplicial_object.augmented Cᵒᵖ :=
{ left := opposite.op X.right,
  right := X.left.right_op,
  hom := X.hom.right_op }

/-- Construct an augmented simplicial object from an augmented cosimplicial
object in the opposite category. -/
@[simps]
def cosimplicial_object.augmented.left_op (X : cosimplicial_object.augmented Cᵒᵖ) :
  simplicial_object.augmented C :=
{ left := X.right.left_op,
  right := X.left.unop,
  hom := X.hom.left_op }

/-- Converting an augmented simplicial object to an augmented cosimplicial
object and back is isomorphic to the given object. -/
@[simps]
def simplicial_object.augmented.right_op_left_op_iso (X : simplicial_object.augmented C) :
  X.right_op.left_op ≅ X :=
comma.iso_mk X.left.right_op_left_op_iso (eq_to_iso $ by simp) (by tidy)

/-- Converting an augmented cosimplicial object to an augmented simplicial
object and back is isomorphic to the given object. -/
@[simps]
def cosimplicial_object.augmented.left_op_right_op_iso (X : cosimplicial_object.augmented Cᵒᵖ) :
  X.left_op.right_op ≅ X :=
comma.iso_mk (eq_to_iso $ by simp) X.right.left_op_right_op_iso (by tidy)

variable (C)

/-- A functorial version of `simplicial_object.augmented.right_op`. -/
@[simps]
def simplicial_to_cosimplicial_augmented :
  (simplicial_object.augmented C)ᵒᵖ ⥤ cosimplicial_object.augmented Cᵒᵖ :=
{ obj := λ X, X.unop.right_op,
  map := λ X Y f,
  { left := f.unop.right.op,
    right := f.unop.left.right_op,
    w' := begin
      ext x,
      dsimp,
      simp_rw ← op_comp,
      congr' 1,
      exact (congr_app f.unop.w (op x)).symm,
    end } }

/-- A functorial version of `cosimplicial_object.augmented.left_op`. -/
@[simps]
def cosimplicial_to_simplicial_augmented :
  cosimplicial_object.augmented Cᵒᵖ ⥤ (simplicial_object.augmented C)ᵒᵖ :=
{ obj := λ X, opposite.op X.left_op,
  map := λ X Y f, quiver.hom.op $
  { left := f.right.left_op,
    right := f.left.unop,
    w' := begin
      ext x,
      dsimp,
      simp_rw ← unop_comp,
      congr' 1,
      exact (congr_app f.w x.unop).symm,
    end} }

/-- The contravariant categorical equivalence between augmented simplicial
objects and augmented cosimplicial objects in the opposite category. -/
@[simps]
def simplicial_cosimplicial_augmented_equiv :
  (simplicial_object.augmented C)ᵒᵖ ≌ cosimplicial_object.augmented Cᵒᵖ :=
{ functor := simplicial_to_cosimplicial_augmented _,
  inverse := cosimplicial_to_simplicial_augmented _,
  unit_iso := nat_iso.of_components
    (λ X, X.unop.right_op_left_op_iso.op) begin
      intros X Y f,
      dsimp,
      rw (show f = f.unop.op, by simp),
      simp_rw ← op_comp,
      congr' 1,
      tidy,
    end,
  counit_iso := nat_iso.of_components
    (λ X, X.left_op_right_op_iso) (by tidy) }

end category_theory


/-
Copyright (c) 2021 . All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import group_theory.group_action.basic
import group_theory.subgroup.basic
import algebra.group_ring_action
/-!
# Conjugation action of a group on itself

This file defines the conjugation action of a group on itself. See also `mul_aut.conj` for
the definition of conjugation as a homomorphism into the automorphism group.

## Main definitions

A type alias `conj_act G` is introduced for a group `G`. The group `conj_act G` acts on `G`
by conjugation. The group `conj_act G` also acts on any normal subgroup of `G` by conjugation.

As a generalization, this also allows:
* `conj_act Mˣ` to act on `M`, when `M` is a `monoid`
* `conj_act G₀` to act on `G₀`, when `G₀` is a `group_with_zero`

## Implementation Notes

The scalar action in defined in this file can also be written using `mul_aut.conj g • h`. This
has the advantage of not using the type alias `conj_act`, but the downside of this approach
is that some theorems about the group actions will not apply when since this
`mul_aut.conj g • h` describes an action of `mul_aut G` on `G`, and not an action of `G`.

-/

variables (M G G₀ R K : Type*)

/-- A type alias for a group `G`. `conj_act G` acts on `G` by conjugation -/
def conj_act : Type* := G

namespace conj_act
open mul_action subgroup

variables {M G G₀ R K}

instance : Π [group G], group (conj_act G) := id
instance : Π [div_inv_monoid G], div_inv_monoid (conj_act G) := id
instance : Π [group_with_zero G], group_with_zero (conj_act G) := id
instance : Π [fintype G], fintype (conj_act G) := id

@[simp] lemma card [fintype G] : fintype.card (conj_act G) = fintype.card G := rfl

section div_inv_monoid

variable [div_inv_monoid G]

instance : inhabited (conj_act G) := ⟨1⟩

/-- Reinterpret `g : conj_act G` as an element of `G`. -/
def of_conj_act : conj_act G ≃* G := ⟨id, id, λ _, rfl, λ _, rfl, λ _ _, rfl⟩

/-- Reinterpret `g : G` as an element of `conj_act G`. -/
def to_conj_act : G ≃* conj_act G := of_conj_act.symm

/-- A recursor for `conj_act`, for use as `induction x using conj_act.rec` when `x : conj_act G`. -/
protected def rec {C : conj_act G → Sort*} (h : Π g, C (to_conj_act g)) : Π g, C g := h

@[simp] lemma of_mul_symm_eq : (@of_conj_act G _).symm = to_conj_act := rfl
@[simp] lemma to_mul_symm_eq : (@to_conj_act G _).symm = of_conj_act := rfl
@[simp] lemma to_conj_act_of_conj_act (x : conj_act G) : to_conj_act (of_conj_act x) = x := rfl
@[simp] lemma of_conj_act_to_conj_act (x : G) : of_conj_act (to_conj_act x) = x := rfl
@[simp] lemma of_conj_act_one : of_conj_act (1 : conj_act G) = 1 := rfl
@[simp] lemma to_conj_act_one : to_conj_act (1 : G) = 1 := rfl
@[simp] lemma of_conj_act_inv (x : conj_act G) : of_conj_act (x⁻¹) = (of_conj_act x)⁻¹ := rfl
@[simp] lemma to_conj_act_inv (x : G) : to_conj_act (x⁻¹) = (to_conj_act x)⁻¹ := rfl
@[simp] lemma of_conj_act_mul (x y : conj_act G) :
  of_conj_act (x * y) = of_conj_act x * of_conj_act y := rfl
@[simp] lemma to_conj_act_mul (x y : G) : to_conj_act (x * y) =
  to_conj_act x * to_conj_act y := rfl

instance : has_scalar (conj_act G) G :=
{ smul := λ g h, of_conj_act g * h * (of_conj_act g)⁻¹ }

lemma smul_def (g : conj_act G) (h : G) : g • h = of_conj_act g * h * (of_conj_act g)⁻¹ := rfl

@[simp] lemma «forall» (p : conj_act G → Prop) :
  (∀ (x : conj_act G), p x) ↔ ∀ x : G, p (to_conj_act x) := iff.rfl

end div_inv_monoid

section units

section monoid
variables [monoid M]

instance has_units_scalar : has_scalar (conj_act Mˣ) M :=
{ smul := λ g h, of_conj_act g * h * ↑(of_conj_act g)⁻¹ }

lemma units_smul_def (g : conj_act Mˣ) (h : M) : g • h = of_conj_act g * h * ↑(of_conj_act g)⁻¹ :=
rfl

instance units_mul_distrib_mul_action : mul_distrib_mul_action (conj_act Mˣ) M :=
{ smul := (•),
  one_smul := by simp [units_smul_def],
  mul_smul := by simp [units_smul_def, mul_assoc, mul_inv_rev],
  smul_mul := by simp [units_smul_def, mul_assoc],
  smul_one := by simp [units_smul_def], }

end monoid

section semiring
variables [semiring R]

instance units_mul_semiring_action : mul_semiring_action (conj_act Rˣ) R :=
{ smul := (•),
  smul_zero := by simp [units_smul_def],
  smul_add := by simp [units_smul_def, mul_add, add_mul],
  ..conj_act.units_mul_distrib_mul_action}

end semiring

end units

section group_with_zero
variable [group_with_zero G₀]

@[simp] lemma of_conj_act_zero : of_conj_act (0 : conj_act G₀) = 0 := rfl
@[simp]

instance mul_action₀ : mul_action (conj_act G₀) G₀ :=
{ smul := (•),
  one_smul := by simp [smul_def],
  mul_smul := by simp [smul_def, mul_assoc, mul_inv_rev] }

end group_with_zero

section division_ring
variables [division_ring K]

instance distrib_mul_action₀ : distrib_mul_action (conj_act K) K :=
{ smul := (•),
  smul_zero := by simp [smul_def],
  smul_add := by simp [smul_def, mul_add, add_mul],
  ..conj_act.mul_action₀ }

end division_ring

variables [group G]

instance : mul_distrib_mul_action (conj_act G) G :=
{ smul := (•),
  smul_mul := by simp [smul_def, mul_assoc],
  smul_one := by simp [smul_def],
  one_smul := by simp [smul_def],
  mul_smul := by simp [smul_def, mul_assoc] }

lemma smul_eq_mul_aut_conj (g : conj_act G) (h : G) : g • h = mul_aut.conj (of_conj_act g) h := rfl

/-- The set of fixed points of the conjugation action of `G` on itself is the center of `G`. -/
lemma fixed_points_eq_center : fixed_points (conj_act G) G = center G :=
begin
  ext x,
  simp [mem_center_iff, smul_def, mul_inv_eq_iff_eq_mul]
end

/-- As normal subgroups are closed under conjugation, they inherit the conjugation action
  of the underlying group. -/
instance subgroup.conj_action {H : subgroup G} [hH : H.normal] :
  has_scalar (conj_act G) H :=
⟨λ g h, ⟨g • h, hH.conj_mem h.1 h.2 (of_conj_act g)⟩⟩

lemma subgroup.coe_conj_smul {H : subgroup G} [hH : H.normal] (g : conj_act G) (h : H) :
  ↑(g • h) = g • (h : G) := rfl

instance subgroup.conj_mul_distrib_mul_action {H : subgroup G} [hH : H.normal] :
  mul_distrib_mul_action (conj_act G) H :=
(subtype.coe_injective).mul_distrib_mul_action H.subtype subgroup.coe_conj_smul

/-- Group conjugation on a normal subgroup. Analogous to `mul_aut.conj`. -/
def _root_.mul_aut.conj_normal {H : subgroup G} [hH : H.normal] : G →* mul_aut H :=
(mul_distrib_mul_action.to_mul_aut (conj_act G) H).comp to_conj_act.to_monoid_hom

@[simp] lemma _root_.mul_aut.conj_normal_apply {H : subgroup G} [H.normal] (g : G) (h : H) :
  ↑(mul_aut.conj_normal g h) = g * h * g⁻¹ := rfl

@[simp] lemma _root_.mul_aut.conj_normal_symm_apply {H : subgroup G} [H.normal] (g : G) (h : H) :
  ↑((mul_aut.conj_normal g).symm h) = g⁻¹ * h * g :=
by { change _ * (_)⁻¹⁻¹ = _, rw inv_inv, refl }

@[simp] lemma _root_.mul_aut.conj_normal_inv_apply {H : subgroup G} [H.normal] (g : G) (h : H) :
  ↑((mul_aut.conj_normal g)⁻¹ h) = g⁻¹ * h * g :=
mul_aut.conj_normal_symm_apply g h

lemma _root_.mul_aut.conj_normal_coe {H : subgroup G} [H.normal] {h : H} :
  mul_aut.conj_normal ↑h = mul_aut.conj h :=
mul_equiv.ext (λ x, rfl)

instance normal_of_characteristic_of_normal {H : subgroup G} [hH : H.normal]
  {K : subgroup H} [h : K.characteristic] : (K.map H.subtype).normal :=
⟨λ a ha b, by
{ obtain ⟨a, ha, rfl⟩ := ha,
  exact K.apply_coe_mem_map H.subtype
    ⟨_, ((set_like.ext_iff.mp (h.fixed (mul_aut.conj_normal b)) a).mpr ha)⟩ }⟩

end conj_act


import algebra.group_power tactic.norm_num algebra.big_operators

theorem Q5 : (¬ (∃ a b c : ℕ, 6*a+9*b+20*c = 43))
             ∧ ∀ m, m ≥ 44 → ∃ a b c : ℕ, 6*a+9*b+20*c = m := sorry


/-
A proof of the main theorem of the whitepaper:

Given a collection of data meeting all the constraints in `constraints`, assuming the extra
probabilistic assumptions hold, there is an execution trace according to the semantics given in
`cpu`, with the given length, start state, and final value of the program counter.
-/
import starkware.cairo.lean.semantics.cpu
import starkware.cairo.lean.semantics.air_encoding.constraints
import starkware.cairo.lean.semantics.air_encoding.memory
import starkware.cairo.lean.semantics.air_encoding.range_check
import starkware.cairo.lean.semantics.air_encoding.instruction
import starkware.cairo.lean.semantics.air_encoding.step
import starkware.cairo.lean.semantics.air_encoding.range_check_builtin

open_locale classical

/- assume F is a sufficiently large finite field -/
variables {F : Type} [field F] [fintype F]

/-
The probabilistic assumptions.
-/

structure hprob {inp : input_data_aux F} (c : constraints inp) :=
(hprob₁ : c.mc.mb.alpha ∉ bad_set_1 (real_a inp.mem_star c.mc.a c.mc.em.embed_mem)
                            (real_v inp.mem_star c.mc.v c.mc.em.embed_mem) c.mc.mb.a' c.mc.mb.v')
(hprob₂ : c.mc.mb.z ∉ bad_set_2 (real_a inp.mem_star c.mc.a c.mc.em.embed_mem)
                            (real_v inp.mem_star c.mc.v c.mc.em.embed_mem) c.mc.mb.a' c.mc.mb.v'
                            c.mc.mb.alpha)
(hprob₃ : c.mc.mb.z ≠ 0)
(hprob₄ : c.rc.z ∉ bad_set_3 c.rc.a c.rc.a')

/--
The main theorem: if the constraints hold for the trace data, then for any memory assignment
that agrees with the input data, the memory locations associated with the range check builtin
have been range checked, and there is an execution trace that agrees with the input data.
-/

theorem execution_exists (char_ge : ring_char F ≥ 2^63)
    (inp : input_data_aux F) (c : constraints inp) (hp : hprob c) :
  ∃ mem : F → F,
    option.fn_extends mem inp.mem_star ∧
    (∀ i < inp.rc_len, ∃ n < 2^128, mem (inp.initial_rc_addr + i) = ↑n) ∧
    ∃ exec : fin (inp.T + 1) → register_state F,
      (exec 0).pc = inp.pc_I ∧
      (exec 0).ap = inp.ap_I ∧
      (exec 0).fp = inp.ap_I ∧
      (exec (fin.last inp.T)).pc = inp.pc_F ∧
      (exec (fin.last inp.T)).ap = inp.ap_F ∧
    ∀ i : fin inp.T, next_state mem (exec i.cast_succ) (exec i.succ) :=
begin
  have char_gt : ring_char F > 2^16,
  { apply lt_of_lt_of_le _ char_ge, apply pow_lt_pow; norm_num },
  let m := mem c.mc.mb.a' c.mc.mb.v',
  have mem_extends : option.fn_extends m inp.mem_star :=
         mem_extends c.mc.mb.h_continuity c.mc.mb.h_single_valued
           c.mc.mb.h_initial c.mc.mb.h_cumulative c.mc.mb.h_final c.mc.em.h_embed_dom
           c.mc.em.h_embed_val c.mc.em.h_embed_mem_inj hp.hprob₃ hp.hprob₁ hp.hprob₂ c.mc.h_n_lt,
  have mem_pc_addr : ∀ i : fin inp.T, m (c.pc i.cast_succ) = c.inst i :=
         mem_pc c.mc.mb.h_continuity c.mc.mb.h_single_valued c.mc.mb.h_initial
           c.mc.mb.h_cumulative c.mc.mb.h_final c.mc.em.h_embed_pc c.mc.em.h_embed_inst
           c.mc.em.h_embed_dom c.mc.em.h_embed_val c.mc.em.h_embed_mem_inj
           c.mc.em.h_embed_mem_disj_inst hp.hprob₃ hp.hprob₁ hp.hprob₂ c.mc.h_n_lt,
  have mem_dst_addr : ∀ i, m (c.dst_addr i) = c.dst i :=
         mem_dst_addr
           c.mc.mb.h_continuity c.mc.mb.h_single_valued c.mc.mb.h_initial c.mc.mb.h_cumulative
           c.mc.mb.h_final c.mc.em.h_embed_dst_addr c.mc.em.h_embed_dst c.mc.em.h_embed_dom
           c.mc.em.h_embed_val c.mc.em.h_embed_mem_inj c.mc.em.h_embed_mem_disj_dst
           hp.hprob₃ hp.hprob₁ hp.hprob₂ c.mc.h_n_lt,
  have mem_op0_addr : ∀ i, m (c.op0_addr i) = c.op0 i :=
        mem_op0_addr
          c.mc.mb.h_continuity c.mc.mb.h_single_valued c.mc.mb.h_initial c.mc.mb.h_cumulative
          c.mc.mb.h_final c.mc.em.h_embed_op0_addr c.mc.em.h_embed_op0 c.mc.em.h_embed_dom
          c.mc.em.h_embed_val c.mc.em.h_embed_mem_inj c.mc.em.h_embed_mem_disj_op0
          hp.hprob₃ hp.hprob₁ hp.hprob₂ c.mc.h_n_lt,
  have mem_op1_addr : ∀ i, m (c.op1_addr i) = c.op1 i :=
        mem_op1_addr
          c.mc.mb.h_continuity c.mc.mb.h_single_valued c.mc.mb.h_initial c.mc.mb.h_cumulative
          c.mc.mb.h_final c.mc.em.h_embed_op1_addr c.mc.em.h_embed_op1 c.mc.em.h_embed_dom
          c.mc.em.h_embed_val c.mc.em.h_embed_mem_inj c.mc.em.h_embed_mem_disj_op1
          hp.hprob₃ hp.hprob₁ hp.hprob₂ c.mc.h_n_lt,
  have mem_rc_addr : ∀ i, m (c.rc_addr i) = c.rc_val i :=
        mem_rc_addr
          c.mc.mb.h_continuity c.mc.mb.h_single_valued c.mc.mb.h_initial c.mc.mb.h_cumulative
          c.mc.mb.h_final c.mc.em.h_embed_rc_addr c.mc.em.h_embed_rc c.mc.em.h_embed_dom
          c.mc.em.h_embed_val c.mc.em.h_embed_mem_inj c.mc.em.h_embed_mem_disj_rc
          hp.hprob₃ hp.hprob₁ hp.hprob₂ c.mc.h_n_lt,
  have off_op0_in_range : ∀ i, ∃ k : ℕ, k < 2^16 ∧ c.off_op0_tilde i = ↑k :=
        off_op0_in_range c.rc.h_continuity c.rc.h_initial c.rc.h_cumulative c.rc.h_final
        c.rc.h_rc_min c.rc.h_rc_max c.rc.h_embed_op0 c.rc.h_n_lt inp.h_rc_lt inp.h_rc_le char_gt
        hp.hprob₄,
  have off_op1_in_range : ∀ i, ∃ k : ℕ, k < 2^16 ∧ c.off_op1_tilde i = ↑k :=
        off_op1_in_range c.rc.h_continuity c.rc.h_initial c.rc.h_cumulative c.rc.h_final
        c.rc.h_rc_min c.rc.h_rc_max c.rc.h_embed_op1 c.rc.h_n_lt inp.h_rc_lt inp.h_rc_le char_gt
        hp.hprob₄,
  have off_dst_in_range : ∀ i, ∃ k : ℕ, k < 2^16 ∧ c.off_dst_tilde i = ↑k :=
        off_dst_in_range c.rc.h_continuity c.rc.h_initial c.rc.h_cumulative c.rc.h_final
        c.rc.h_rc_min c.rc.h_rc_max c.rc.h_embed_dst c.rc.h_n_lt inp.h_rc_lt inp.h_rc_le char_gt
        hp.hprob₄,
  have rc16_vals_in_range : ∀ i, ∃ k : ℕ, k < 2^16 ∧ c.rc16_val i = ↑k :=
        rc16_vals_in_range c.rc.h_continuity c.rc.h_initial c.rc.h_cumulative c.rc.h_final
        c.rc.h_rc_min c.rc.h_rc_max c.rc.h_embed_rc16 c.rc.h_n_lt inp.h_rc_lt inp.h_rc_le char_gt
        hp.hprob₄,
  have range_checked :
    ∀ i < inp.rc_len, ∃ n < 2^128, m (inp.initial_rc_addr + i) = ↑n,
  { intros i hi,
    rcases rc_val_checked rc16_vals_in_range c.rcb.h_rc_value ⟨i, hi⟩ with ⟨n, nlt, neq⟩,
    use [n, nlt],
    rw ←neq, dsimp, rw ←mem_rc_addr,
    rw rc_addr_eq c.rcb.h_rc_init_addr c.rcb.h_rc_addr_step  ⟨i, hi⟩,
    refl },
  use [m, mem_extends, range_checked],
  let e := λ i : fin (inp.T + 1), register_state.mk (c.pc i) (c.ap i) (c.fp i),
  use [e, c.h_pc_I, c.h_ap_I, c.h_fp_I, c.h_pc_F, c.h_ap_F],
  intro i,
  show next_state m (e i.cast_succ) (e i.succ),
  let inst' := the_instruction (c.ic i).h_bit (off_op0_in_range i) (off_op1_in_range i)
                (off_dst_in_range i),
  have inst_eq : c.inst i = ↑(inst'.to_nat) :=
        inst_eq (c.ic i).h_instruction (c.ic i).h_bit (c.ic i).h_last_value
        (off_op0_in_range i) (off_op1_in_range i) (off_dst_in_range i),
  have off_dst_tilde_eq : c.off_dst_tilde i = ↑(inst'.off_dst.to_natr) :=
        off_dst_tilde_eq (c.ic i).h_bit (off_op0_in_range i) (off_op1_in_range i)
          (off_dst_in_range i),
  have off_op0_tilde_eq : c.off_op0_tilde i = ↑(inst'.off_op0.to_natr) :=
        off_op0_tilde_eq (c.ic i).h_bit (off_op0_in_range i) (off_op1_in_range i)
          (off_dst_in_range i),
  have off_op1_tilde_eq : c.off_op1_tilde i = ↑(inst'.off_op1.to_natr) :=
        off_op1_tilde_eq (c.ic i).h_bit (off_op0_in_range i) (off_op1_in_range i)
          (off_dst_in_range i),
  have f_tilde_to_f_eq : ∀ j, (c.f_tilde i).to_f j = ↑((inst'.flags.nth j).to_nat) :=
      f_tilde_to_f_eq (c.ic i).h_bit (off_op0_in_range i) (off_op1_in_range i)
        (off_dst_in_range i),
  exact next_state_eq off_dst_tilde_eq off_op0_tilde_eq off_op1_tilde_eq f_tilde_to_f_eq
    ((mem_pc_addr i).trans inst_eq) (mem_dst_addr i) (mem_op0_addr i) (mem_op1_addr i)
    (c.sc i).h_dst_addr (c.sc i).h_op0_addr (c.sc i).h_op1_addr (c.sc i).h_mul
    (c.sc i).h_res (c.sc i).h_t0_eq (c.sc i).h_t1_eq (c.sc i).h_next_pc_eq (c.sc i).h_next_pc_eq'
    (c.sc i).h_opcode_call (c.sc i).h_opcode_call' (c.sc i).h_opcode_assert_eq
    (c.sc i).h_next_ap (c.sc i).h_next_fp
end


import algebra.ring.boolean_ring

def φ : Prop :=
  ∀ x : fin 19, ∀ y : fin 30, ∀ z : fin 35,
  143 * x.1 + 91 * y.1 + 77 * z.1 = 2692 ↔ x.1 = 6 ∧ y.1 = 10 ∧ z.1 = 12

def ψ : Prop :=
  ∀ x y z : ℕ, 143 * x + 91 * y + 77 * z = 2692 ↔ x = 6 ∧ y = 10 ∧ z = 12

instance myφ : decidable (φ) := decidable_of_iff (∀ x : fin 19, ∀ y : fin 30, ∀ z : fin 35,
    143 * x.1 + 91 * y.1 + 77 * z.1 = 2692 ↔ x.1 = 6 ∧ y.1 = 10 ∧ z.1 = 12) (by rw φ)

theorem decide_diophantine3_1 (a b c n x y z : ℕ):
a*x+b*y+c*z =n → 0 < a → x < n/a + 1
:=
λ h, λ ha: 0 < a,
have hh: x*a ≤ n, from calc x*a = a*x + 0     : by ring
                        ... ≤ a*x + (b*y+c*z) : add_le_add_left (nat.zero_le  _) (a*x)
                        ... = a*x + b*y + c*z : by ring
                        ... = n               : h,
  calc _ ≤ n/a           : (nat.le_div_iff_mul_le ha).mpr hh
     ... < _             : lt_add_one (n/a)

theorem decide_diophantine3_3 (a b c n x y z : ℕ):
a*x+b*y+c*z =n → 0 < a → 0 < b → 0 < c → x < n/a + 1 ∧ y < n/b + 1 ∧ z < n/c + 1
:=
λ g1, λ ha hb hc,
have g2:b*y+a*x+c*z =n, from calc _ = a*x+b*y+c*z: by ring
                                ... = _: g1,
have g3:c*z+a*x+b*y =n, from calc _ = a*x+b*y+c*z: by ring
                                ... = _: g1,
have h1: x < n/a + 1, from decide_diophantine3_1 a b c n x y z g1 ha,
have h2: y < n/b + 1, from decide_diophantine3_1 b a c n y x z g2 hb,
have h3: z < n/c + 1, from decide_diophantine3_1 c a b n z x y g3 hc,
and.intro h1 (and.intro h2 h3)

-- #eval 2692/143 -- 18
-- #eval 2692/91  -- 29
-- #eval 2692/77  -- 34
instance remark_2_15 :
  decidable ψ :=
  decidable_of_iff φ
  (
    iff.intro (
      λ h x y z, iff.intro
      -- sorry
      (
        λ h1,
        have H: 143 * x + 91 * y + 77 * z = 2692 ↔ x=6∧  y=10 ∧ z=12, from
          h ⟨ x,
            (decide_diophantine3_3
              143 91 77 2692 x y z h1 dec_trivial dec_trivial dec_trivial).1
          ⟩ ⟨y,
            (decide_diophantine3_3
              143 91 77 2692 x y z h1 dec_trivial dec_trivial dec_trivial).2.1
          ⟩ ⟨z,
            (decide_diophantine3_3
              143 91 77 2692 x y z h1 dec_trivial dec_trivial dec_trivial).2.2
          ⟩,
        H.mp h1
      )
      (
        λ hxyz,
          calc 143 * x + 91 *  y + 77 * z
             = 143 * x + 91 *  y + 77 * 12: by rw hxyz.2.2
         ... = 143 * x + 91 * 10 + 77 * 12: by rw hxyz.2.1
         ... = 143 * 6 + 91 * 10 + 77 * 12: by rw hxyz.1
         ... = 2692: dec_trivial
      )
    ) (
      λ h, λ x y z, h x.val y.val z.val
    )
  )

/- This: -/

--example : ψ := dec_trivial

/- does not terminate in a reasonable amount of time,
  but it is semi-formally verified by the #eval below
-/

#eval (φ : bool) -- tt


/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import tactic.monotonicity
import tactic.norm_num
import algebra.order.ring.defs
import measure_theory.measure.lebesgue
import measure_theory.function.locally_integrable
import data.list.defs

open list tactic tactic.interactive set

example
  (h : 3 + 6 ≤ 4 + 5)
: 1 + 3 + 2 + 6 ≤ 4 + 2 + 1 + 5 :=
begin
  ac_mono,
end

example
  (h : 3 ≤ (4 : ℤ))
  (h' : 5 ≤ (6 : ℤ))
: (1 + 3 + 2) - 6 ≤ (4 + 2 + 1 : ℤ) - 5 :=
begin
  ac_mono,
  mono,
end

example
  (h : 3 ≤ (4 : ℤ))
  (h' : 5 ≤ (6 : ℤ))
: (1 + 3 + 2) - 6 ≤ (4 + 2 + 1 : ℤ) - 5 :=
begin
  transitivity (1 + 3 + 2 - 5 : ℤ),
  { ac_mono },
  { ac_mono },
end

example (x y z k : ℕ)
  (h : 3 ≤ (4 : ℕ))
  (h' : z ≤ y)
: (k + 3 + x) - y ≤ (k + 4 + x) - z :=
begin
  mono, norm_num
end

example (x y z k : ℤ)
  (h : 3 ≤ (4 : ℤ))
  (h' : z ≤ y)
: (k + 3 + x) - y ≤ (k + 4 + x) - z :=
begin
  mono, norm_num
end

example (x y z a b : ℕ)
  (h : a ≤ (b : ℕ))
  (h' : z ≤ y)
: (1 + a + x) - y ≤ (1 + b + x) - z :=
begin
  transitivity (1 + a + x - z),
  { mono, },
  { mono, mono, mono },
end

example (x y z a b : ℤ)
  (h : a ≤ (b : ℤ))
  (h' : z ≤ y)
: (1 + a + x) - y ≤ (1 + b + x) - z :=
begin
  transitivity (1 + a + x - z),
  { mono, },
  { mono, mono, mono },
end

example (x y z : ℤ)
  (h' : z ≤ y)
: (1 + 3 + x) - y ≤ (1 + 4 + x) - z :=
begin
  transitivity (1 + 3 + x - z),
  { mono },
  { mono, mono, norm_num },
end

example (x y z : ℤ)
  (h : 3 ≤ (4 : ℤ))
  (h' : z ≤ y)
: (1 + 3 + x) - y ≤ (1 + 4 + x) - z :=
begin
  ac_mono, mono*
end

@[simp]
def list.le' {α : Type*} [has_le α] : list α → list α → Prop
 | (x::xs) (y::ys) := x ≤ y ∧ list.le' xs ys
 | [] [] := true
 | _ _ := false

@[simp]
instance list_has_le {α : Type*} [has_le α] : has_le (list α) :=
⟨ list.le' ⟩

lemma list.le_refl {α : Type*} [preorder α] {xs : list α}
: xs ≤ xs :=
begin
  induction xs with x xs,
  { trivial },
  { simp [has_le.le,list.le],
    split, exact le_rfl, apply xs_ih }
end

-- @[trans]
lemma list.le_trans {α : Type*} [preorder α]
  {xs zs : list α} (ys : list α)
  (h  : xs ≤ ys)
  (h' : ys ≤ zs)
: xs ≤ zs :=
begin
  revert ys zs,
  induction xs with x xs
  ; intros ys zs h h'
  ; cases ys with y ys
  ; cases zs with z zs
  ; try { cases h ; cases h' ; done },
  { apply list.le_refl },
  { simp [has_le.le,list.le],
    split,
    apply le_trans h.left h'.left,
    apply xs_ih _ h.right h'.right, }
end

@[mono]
lemma list_le_mono_left {α : Type*} [preorder α] {xs ys zs : list α}
  (h : xs ≤ ys)
: xs ++ zs ≤ ys ++ zs :=
begin
  revert ys,
  induction xs with x xs ; intros ys h,
  { cases ys, apply list.le_refl, cases h },
  { cases ys with y ys, cases h, simp [has_le.le,list.le] at *,
    revert h, apply and.imp_right,
    apply xs_ih }
end

@[mono]
lemma list_le_mono_right {α : Type*} [preorder α] {xs ys zs : list α}
  (h : xs ≤ ys)
: zs ++ xs ≤ zs ++ ys :=
begin
  revert ys zs,
  induction xs with x xs ; intros ys zs h,
  { cases ys, { simp, apply list.le_refl }, cases h },
  { cases ys with y ys, cases h, simp [has_le.le,list.le] at *,
    suffices : list.le' ((zs ++ [x]) ++ xs) ((zs ++ [y]) ++ ys),
    { refine cast _ this, simp, },
    apply list.le_trans (zs ++ [y] ++ xs),
    { apply list_le_mono_left,
      induction zs with z zs,
      { simp [has_le.le,list.le], apply h.left },
      { simp [has_le.le,list.le], split, exact le_rfl,
        apply zs_ih, } },
    { apply xs_ih h.right, } }
end

lemma bar_bar'
  (h : [] ++ [3] ++ [2] ≤ [1] ++ [5] ++ [4])
: [] ++ [3] ++ [2] ++ [2] ≤ [1] ++ [5] ++ ([4] ++ [2]) :=
begin
  ac_mono,
end

lemma bar_bar''
  (h : [3] ++ [2] ++ [2] ≤ [5] ++ [4] ++ [])
: [1] ++ ([3] ++ [2]) ++ [2] ≤ [1] ++ [5] ++ ([4] ++ []) :=
begin
  ac_mono,
end

lemma bar_bar
  (h : [3] ++ [2] ≤ [5] ++ [4])
: [1] ++ [3] ++ [2] ++ [2] ≤ [1] ++ [5] ++ ([4] ++ [2]) :=
begin
  ac_mono,
end

def P (x : ℕ) := 7 ≤ x
def Q (x : ℕ) := x ≤ 7

@[mono]
lemma P_mono {x y : ℕ}
  (h : x ≤ y)
: P x → P y :=
by { intro h', apply le_trans h' h }

@[mono]
lemma Q_mono {x y : ℕ}
  (h : y ≤ x)
: Q x → Q y :=
by apply le_trans h

example (x y z : ℕ)
  (h : x ≤ y)
: P (x + z) → P (z + y) :=
begin
  ac_mono,
  ac_mono,
end

example (x y z : ℕ)
  (h : y ≤ x)
: Q (x + z) → Q (z + y) :=
begin
  ac_mono,
  ac_mono,
end

example (x y z k m n : ℤ)
  (h₀ : z ≤ 0)
  (h₁ : y ≤ x)
: (m + x + n) * z + k ≤ z * (y + n + m) + k :=
begin
  ac_mono,
  ac_mono,
  ac_mono,
end

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,
  ac_mono,
  ac_mono,
end

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

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

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₁ }

example (x y z k m n : ℕ)
  (h₀ : z ≥ 0)
  (h₁ : n + x + m ≤ y + n + m)
: (m + x + n) * z + k ≤ z * (y + n + m) + k :=
begin
  ac_mono* : m + x + n ≤ y + n + m,
  transitivity ; [ skip , apply h₁ ],
  apply le_of_eq,
  ac_refl,
end

example (x y z k m n : ℤ)
  (h₁ : x ≤ y)
: true :=
begin
  have : (m + x + n) * z + k ≤ z * (y + n + m) + k,
  { ac_mono,
    success_if_fail { ac_mono },
    admit },
  trivial
end

example (x y z k m n : ℕ)
  (h₁ : x ≤ y)
: true :=
begin
  have : (m + x + n) * z + k ≤ z * (y + n + m) + k,
  { ac_mono*,
    change 0 ≤ z, apply nat.zero_le, },
  trivial
end

example (x y z k m n : ℕ)
  (h₁ : x ≤ y)
: true :=
begin
  have : (m + x + n) * z + k ≤ z * (y + n + m) + k,
  { ac_mono,
    change (m + x + n) * z ≤ z * (y + n + m),
    admit },
  trivial,
end

example (x y z k m n i j : ℕ)
  (h₁ : x + i = y + j)
: (m + x + n + i) * z + k = z * (j + n + m + y) + k :=
begin
  ac_mono^3,
  cc
end

example (x y z k m n i j : ℕ)
  (h₁ : x + i = y + j)
: z * (x + i + n + m) + k = z * (y + j + n + m) + k :=
begin
  congr,
  simp [h₁],
end

example (x y z k m n i j : ℕ)
  (h₁ : x + i = y + j)
: (m + x + n + i) * z + k = z * (j + n + m + y) + k :=
begin
  ac_mono*,
  cc,
end

example (x y : ℕ)
  (h : x ≤ y)
: true :=
begin
  (do v ← mk_mvar,
      p ← to_expr ```(%%v + x ≤ y + %%v),
      assert `h' p),
  ac_mono := h,
  trivial,
  exact 1,
end

example {x y z : ℕ} : true :=
begin
  have : y + x ≤ y + z,
  { mono,
    guard_target' x ≤ z,
    admit },
  trivial
end

example {x y z : ℕ} : true :=
begin
  suffices : x + y ≤ z + y, trivial,
  mono,
  guard_target' x ≤ z,
  admit,
end

example {x y z w : ℕ} : true :=
begin
  have : x + y ≤ z + w,
  { mono,
    guard_target' x ≤ z, admit,
    guard_target' y ≤ w, admit },
  trivial
end

example {x y z w : ℕ} : true :=
begin
  have : x * y ≤ z * w,
  { mono with [0 ≤ z,0 ≤ y],
    { guard_target 0 ≤ z, admit },
    { guard_target 0 ≤ y, admit },
    guard_target' x ≤ z, admit,
    guard_target' y ≤ w, admit },
  trivial
end

example {x y z w : Prop} : true :=
begin
  have : x ∧ y → z ∧ w,
  { mono,
    guard_target' x → z, admit,
    guard_target' y → w, admit },
  trivial
end

example {x y z w : Prop} : true :=
begin
  have : x ∨ y → z ∨ w,
  { mono,
    guard_target' x → z, admit,
    guard_target' y → w, admit },
  trivial
end

example {x y z w : ℤ} : true :=
begin
  suffices : x + y < w + z, trivial,
  have : x < w, admit,
  have : y ≤ z, admit,
  mono right,
end

example {x y z w : ℤ} : true :=
begin
  suffices : x * y < w * z, trivial,
  have : x < w, admit,
  have : y ≤ z, admit,
  mono right,
  { guard_target' 0 < y, admit },
  { guard_target' 0 ≤ w, admit },
end

open tactic

example (x y : ℕ)
  (h : x ≤ y)
: true :=
begin
  (do v ← mk_mvar,
      p ← to_expr ```(%%v + x ≤ y + %%v),
      assert `h' p),
  ac_mono := h,
  trivial,
  exact 3
end

example {α} [linear_order α]
  (a b c d e : α) :
  max a b ≤ e → b ≤ e :=
by { mono, apply le_max_right }

example (a b c d e : Prop)
  (h : d → a) (h' : c → e) :
  (a ∧ b → c) ∨ d → (d ∧ b → e) ∨ a :=
begin
  mono,
  mono,
  mono,
end

example : ∫ x in Icc 0 1, real.exp x ≤ ∫ x in Icc 0 1, real.exp (x+1) :=
begin
  mono,
  { exact real.continuous_exp.locally_integrable.integrable_on_is_compact is_compact_Icc },
  { exact (real.continuous_exp.comp $ continuous_add_right 1)
      .locally_integrable.integrable_on_is_compact is_compact_Icc },
  intro x,
  dsimp only,
  mono,
  linarith
end


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau, Johan Commelin
-/
import data.mv_polynomial.equiv
import data.mv_polynomial.comm_ring
import logic.equiv.functor
import ring_theory.free_ring

/-!
# Free commutative rings

The theory of the free commutative ring generated by a type `α`.
It is isomorphic to the polynomial ring over ℤ with variables
in `α`

## Main definitions

* `free_comm_ring α`     : the free commutative ring on a type α
* `lift (f : α → R)` : the ring hom `free_comm_ring α →+* R` induced by functoriality from `f`.
* `map (f : α → β)`      : the ring hom `free_comm_ring α →*+ free_comm_ring β` induced by
                           functoriality from f.

## Main results

`free_comm_ring` has functorial properties (it is an adjoint to the forgetful functor).
In this file we have:

* `of : α → free_comm_ring α`
* `lift (f : α → R) : free_comm_ring α →+* R`
* `map (f : α → β) : free_comm_ring α →+* free_comm_ring β`

* `free_comm_ring_equiv_mv_polynomial_int : free_comm_ring α ≃+* mv_polynomial α ℤ` :
    `free_comm_ring α` is isomorphic to a polynomial ring.

## Implementation notes

`free_comm_ring α` is implemented not using `mv_polynomial` but
directly as the free abelian group on `multiset α`, the type
of monomials in this free commutative ring.

## Tags

free commutative ring, free ring
-/

noncomputable theory
open_locale classical polynomial

universes u v

variables (α : Type u)

/-- `free_comm_ring α` is the free commutative ring on the type `α`. -/
@[derive [comm_ring, inhabited]]
def free_comm_ring (α : Type u) : Type u :=
free_abelian_group $ multiplicative $ multiset α

namespace free_comm_ring

variables {α}

/-- The canonical map from `α` to the free commutative ring on `α`. -/
def of (x : α) : free_comm_ring α :=
free_abelian_group.of $ multiplicative.of_add ({x} : multiset α)

lemma of_injective : function.injective (of : α → free_comm_ring α) :=
free_abelian_group.of_injective.comp (λ x y,
  (multiset.coe_eq_coe.trans list.singleton_perm_singleton).mp)

@[elab_as_eliminator] protected lemma induction_on
  {C : free_comm_ring α → Prop} (z : free_comm_ring α)
  (hn1 : C (-1)) (hb : ∀ b, C (of b))
  (ha : ∀ x y, C x → C y → C (x + y))
  (hm : ∀ x y, C x → C y → C (x * y)) : C z :=
have hn : ∀ x, C x → C (-x), from λ x ih, neg_one_mul x ▸ hm _ _ hn1 ih,
have h1 : C 1, from neg_neg (1 : free_comm_ring α) ▸ hn _ hn1,
free_abelian_group.induction_on z
  (add_left_neg (1 : free_comm_ring α) ▸ ha _ _ hn1 h1)
  (λ m, multiset.induction_on m h1 $ λ a m ih, hm _ _ (hb a) ih)
  (λ m ih, hn _ ih)
  ha
section lift

variables {R : Type v} [comm_ring R] (f : α → R)

/-- A helper to implement `lift`. This is essentially `free_comm_monoid.lift`, but this does not
currently exist. -/
private def lift_to_multiset : (α → R) ≃ (multiplicative (multiset α) →* R) :=
{ to_fun := λ f,
  { to_fun := λ s, (s.to_add.map f).prod,
    map_mul' := λ x y, calc _ = multiset.prod ((multiset.map f x) + (multiset.map f y)) :
                                    by {congr' 1, exact multiset.map_add _ _ _}
                          ... = _ : multiset.prod_add _ _,
    map_one' := rfl},
  inv_fun := λ F x, F (multiplicative.of_add ({x} : multiset α)),
  left_inv := λ f, funext $ λ x, show (multiset.map f {x}).prod = _, by simp,
  right_inv := λ F, monoid_hom.ext $ λ x,
    let F' := F.to_additive'', x' := x.to_add in show (multiset.map (λ a, F' {a}) x').sum = F' x',
    begin
      rw [←multiset.map_map, ←add_monoid_hom.map_multiset_sum],
      exact F.congr_arg (multiset.sum_map_singleton x'),
    end }

/-- Lift a map `α → R` to a additive group homomorphism `free_comm_ring α → R`.
For a version producing a bundled homomorphism, see `lift_hom`. -/
def lift : (α → R) ≃ (free_comm_ring α →+* R) :=
equiv.trans lift_to_multiset free_abelian_group.lift_monoid

@[simp] lemma lift_of (x : α) : lift f (of x) = f x :=
(free_abelian_group.lift.of _ _).trans $ mul_one _

@[simp] lemma lift_comp_of (f : free_comm_ring α →+* R) : lift (f ∘ of) = f :=
ring_hom.ext $ λ x, free_comm_ring.induction_on x
  (by rw [ring_hom.map_neg, ring_hom.map_one, f.map_neg, f.map_one])
  (lift_of _)
  (λ x y ihx ihy, by rw [ring_hom.map_add, f.map_add, ihx, ihy])
  (λ x y ihx ihy, by rw [ring_hom.map_mul, f.map_mul, ihx, ihy])

@[ext]
lemma hom_ext ⦃f g : free_comm_ring α →+* R⦄ (h : ∀ x, f (of x) = g (of x)) :
  f = g :=
lift.symm.injective (funext h)

end lift

variables {β : Type v} (f : α → β)

/-- A map `f : α → β` produces a ring homomorphism `free_comm_ring α →+* free_comm_ring β`. -/
def map : free_comm_ring α →+* free_comm_ring β :=
lift $ of ∘ f

@[simp]
lemma map_of (x : α) : map f (of x) = of (f x) := lift_of _ _

/-- `is_supported x s` means that all monomials showing up in `x` have variables in `s`. -/
def is_supported (x : free_comm_ring α) (s : set α) : Prop :=
x ∈ subring.closure (of '' s)

section is_supported
variables {x y : free_comm_ring α} {s t : set α}

theorem is_supported_upwards (hs : is_supported x s) (hst : s ⊆ t) :
  is_supported x t :=
subring.closure_mono (set.monotone_image hst) hs

theorem is_supported_add (hxs : is_supported x s) (hys : is_supported y s) :
  is_supported (x + y) s :=
subring.add_mem _ hxs hys

theorem is_supported_neg (hxs : is_supported x s) :
  is_supported (-x) s :=
subring.neg_mem _ hxs

theorem is_supported_sub (hxs : is_supported x s) (hys : is_supported y s) :
  is_supported (x - y) s :=
subring.sub_mem _ hxs hys

theorem is_supported_mul (hxs : is_supported x s) (hys : is_supported y s) :
  is_supported (x * y) s :=
subring.mul_mem _ hxs hys

theorem is_supported_zero : is_supported 0 s :=
subring.zero_mem _

theorem is_supported_one : is_supported 1 s :=
subring.one_mem _

theorem is_supported_int {i : ℤ} {s : set α} : is_supported ↑i s :=
int.induction_on i is_supported_zero
  (λ i hi, by rw [int.cast_add, int.cast_one]; exact is_supported_add hi is_supported_one)
  (λ i hi, by rw [int.cast_sub, int.cast_one]; exact is_supported_sub hi is_supported_one)

end is_supported

/-- The restriction map from `free_comm_ring α` to `free_comm_ring s` where `s : set α`, defined
  by sending all variables not in `s` to zero. -/
def restriction (s : set α) [decidable_pred (∈ s)] : free_comm_ring α →+* free_comm_ring s :=
lift (λ p, if H : p ∈ s then of (⟨p, H⟩ : s) else 0)

section restriction
variables (s : set α) [decidable_pred (∈ s)] (x y : free_comm_ring α)
@[simp] lemma restriction_of (p) :
  restriction s (of p) = if H : p ∈ s then of ⟨p, H⟩ else 0 := lift_of _ _

end restriction

theorem is_supported_of {p} {s : set α} : is_supported (of p) s ↔ p ∈ s :=
suffices is_supported (of p) s → p ∈ s, from ⟨this, λ hps, subring.subset_closure ⟨p, hps, rfl⟩⟩,
assume hps : is_supported (of p) s, begin
  haveI := classical.dec_pred s,
  have : ∀ x, is_supported x s →
    ∃ (n : ℤ), lift (λ a, if a ∈ s then (0 : ℤ[X]) else polynomial.X) x = n,
  { intros x hx, refine subring.in_closure.rec_on hx _ _ _ _,
    { use 1, rw [ring_hom.map_one], norm_cast },
    { use -1, rw [ring_hom.map_neg, ring_hom.map_one, int.cast_neg, int.cast_one] },
    { rintros _ ⟨z, hzs, rfl⟩ _ _, use 0, rw [ring_hom.map_mul, lift_of, if_pos hzs, zero_mul],
      norm_cast },
    { rintros x y ⟨q, hq⟩ ⟨r, hr⟩, refine ⟨q+r, _⟩, rw [ring_hom.map_add, hq, hr], norm_cast } },
  specialize this (of p) hps, rw [lift_of] at this, split_ifs at this, { exact h },
  exfalso, apply ne.symm int.zero_ne_one,
  rcases this with ⟨w, H⟩, rw ←polynomial.C_eq_int_cast at H,
  have : polynomial.X.coeff 1 = (polynomial.C ↑w).coeff 1, by rw H,
  rwa [polynomial.coeff_C, if_neg (one_ne_zero : 1 ≠ 0), polynomial.coeff_X, if_pos rfl] at this
end

theorem map_subtype_val_restriction {x} (s : set α) [decidable_pred (∈ s)]
  (hxs : is_supported x s) :
  map (subtype.val : s → α) (restriction s x) = x :=
begin
  refine subring.in_closure.rec_on hxs _ _ _ _,
  { rw ring_hom.map_one, refl },
  { rw [ring_hom.map_neg, ring_hom.map_neg, ring_hom.map_one], refl },
  { rintros _ ⟨p, hps, rfl⟩ n ih,
    rw [ring_hom.map_mul, restriction_of, dif_pos hps, ring_hom.map_mul, map_of, ih] },
  { intros x y ihx ihy, rw [ring_hom.map_add, ring_hom.map_add, ihx, ihy] }
end

theorem exists_finite_support (x : free_comm_ring α) :
  ∃ s : set α, set.finite s ∧ is_supported x s :=
free_comm_ring.induction_on x
  ⟨∅, set.finite_empty, is_supported_neg is_supported_one⟩
  (λ p, ⟨{p}, set.finite_singleton p, is_supported_of.2 $ set.mem_singleton _⟩)
  (λ x y ⟨s, hfs, hxs⟩ ⟨t, hft, hxt⟩, ⟨s ∪ t, hfs.union hft, is_supported_add
    (is_supported_upwards hxs $ set.subset_union_left s t)
    (is_supported_upwards hxt $ set.subset_union_right s t)⟩)
  (λ x y ⟨s, hfs, hxs⟩ ⟨t, hft, hxt⟩, ⟨s ∪ t, hfs.union hft, is_supported_mul
    (is_supported_upwards hxs $ set.subset_union_left s t)
    (is_supported_upwards hxt $ set.subset_union_right s t)⟩)

theorem exists_finset_support (x : free_comm_ring α) : ∃ s : finset α, is_supported x ↑s :=
let ⟨s, hfs, hxs⟩ := exists_finite_support x in ⟨hfs.to_finset, by rwa set.finite.coe_to_finset⟩

end free_comm_ring

namespace free_ring
open function
variable (α)

/-- The canonical ring homomorphism from the free ring generated by `α` to the free commutative ring
    generated by `α`. -/
def to_free_comm_ring {α} : free_ring α →+* free_comm_ring α :=
free_ring.lift free_comm_ring.of

instance : has_coe (free_ring α) (free_comm_ring α) := ⟨to_free_comm_ring⟩

/-- The natural map `free_ring α → free_comm_ring α`, as a `ring_hom`. -/
def coe_ring_hom : free_ring α →+* free_comm_ring α := to_free_comm_ring

@[simp, norm_cast] protected lemma coe_zero : ↑(0 : free_ring α) = (0 : free_comm_ring α) := rfl
@[simp, norm_cast] protected lemma coe_one : ↑(1 : free_ring α) = (1 : free_comm_ring α) := rfl

variable {α}

@[simp] protected lemma coe_of (a : α) : ↑(free_ring.of a) = free_comm_ring.of a :=
free_ring.lift_of _ _
@[simp, norm_cast] protected lemma coe_neg (x : free_ring α) : ↑(-x) = -(x : free_comm_ring α) :=
(free_ring.lift _).map_neg _
@[simp, norm_cast] protected lemma coe_add (x y : free_ring α) :
  ↑(x + y) = (x : free_comm_ring α) + y :=
(free_ring.lift _).map_add _ _
@[simp, norm_cast] protected lemma coe_sub (x y : free_ring α) :
  ↑(x - y) = (x : free_comm_ring α) - y :=
(free_ring.lift _).map_sub _ _
@[simp, norm_cast] protected lemma coe_mul (x y : free_ring α) :
  ↑(x * y) = (x : free_comm_ring α) * y :=
(free_ring.lift _).map_mul _ _

variable (α)

protected lemma coe_surjective : surjective (coe : free_ring α → free_comm_ring α) :=
λ x,
begin
  apply free_comm_ring.induction_on x,
  { use -1, refl },
  { intro x, use free_ring.of x, refl },
  { rintros _ _ ⟨x, rfl⟩ ⟨y, rfl⟩, use x + y, exact (free_ring.lift _).map_add _ _ },
  { rintros _ _ ⟨x, rfl⟩ ⟨y, rfl⟩, use x * y, exact (free_ring.lift _).map_mul _ _ }
end

lemma coe_eq :
  (coe : free_ring α → free_comm_ring α) =
  @functor.map free_abelian_group _ _ _ (λ (l : list α), (l : multiset α)) :=
funext $ λ x, free_abelian_group.lift.unique _ _ $ λ L,
by { simp_rw [free_abelian_group.lift.of, (∘)], exact free_monoid.rec_on L rfl
(λ hd tl ih, by { rw [(free_monoid.lift _).map_mul, free_monoid.lift_eval_of, ih], refl }) }

/-- If α has size at most 1 then the natural map from the free ring on `α` to the
    free commutative ring on `α` is an isomorphism of rings. -/
def subsingleton_equiv_free_comm_ring [subsingleton α] :
  free_ring α ≃+* free_comm_ring α :=
ring_equiv.of_bijective (coe_ring_hom _)
  begin
    have : (coe_ring_hom _ : free_ring α → free_comm_ring α) =
      (functor.map_equiv free_abelian_group (multiset.subsingleton_equiv α)) := coe_eq α,
    rw this,
    apply equiv.bijective,
  end

instance [subsingleton α] : comm_ring (free_ring α) :=
{ mul_comm := λ x y,
  by { rw [← (subsingleton_equiv_free_comm_ring α).symm_apply_apply (y * x),
        ((subsingleton_equiv_free_comm_ring α)).map_mul,
        mul_comm,
        ← ((subsingleton_equiv_free_comm_ring α)).map_mul,
        (subsingleton_equiv_free_comm_ring α).symm_apply_apply], },
  .. free_ring.ring α }

end free_ring

/-- The free commutative ring on `α` is isomorphic to the polynomial ring over ℤ with
    variables in `α` -/
def free_comm_ring_equiv_mv_polynomial_int :
  free_comm_ring α ≃+* mv_polynomial α ℤ :=
ring_equiv.of_hom_inv
  (free_comm_ring.lift $ (λ a, mv_polynomial.X a : α → mv_polynomial α ℤ))
  (mv_polynomial.eval₂_hom (int.cast_ring_hom (free_comm_ring α)) free_comm_ring.of)
  (by { ext, simp })
  (by ext; simp)

/-- The free commutative ring on the empty type is isomorphic to `ℤ`. -/
def free_comm_ring_pempty_equiv_int : free_comm_ring pempty.{u+1} ≃+* ℤ :=
ring_equiv.trans (free_comm_ring_equiv_mv_polynomial_int _)
  (mv_polynomial.is_empty_ring_equiv _ pempty)

/-- The free commutative ring on a type with one term is isomorphic to `ℤ[X]`. -/
def free_comm_ring_punit_equiv_polynomial_int : free_comm_ring punit.{u+1} ≃+* ℤ[X] :=
(free_comm_ring_equiv_mv_polynomial_int _).trans (mv_polynomial.punit_alg_equiv ℤ).to_ring_equiv

open free_ring

/-- The free ring on the empty type is isomorphic to `ℤ`. -/
def free_ring_pempty_equiv_int : free_ring pempty.{u+1} ≃+* ℤ :=
ring_equiv.trans (subsingleton_equiv_free_comm_ring _) free_comm_ring_pempty_equiv_int

/-- The free ring on a type with one term is isomorphic to `ℤ[X]`. -/
def free_ring_punit_equiv_polynomial_int : free_ring punit.{u+1} ≃+* ℤ[X] :=
ring_equiv.trans (subsingleton_equiv_free_comm_ring _) free_comm_ring_punit_equiv_polynomial_int


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.witt_vector.basic
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Teichmüller lifts

This file defines `witt_vector.teichmuller`, a monoid hom `R →* 𝕎 R`, which embeds `r : R` as the
`0`-th component of a Witt vector whose other coefficients are `0`.

## Main declarations

- `witt_vector.teichmuller`: the Teichmuller map.
- `witt_vector.map_teichmuller`: `witt_vector.teichmuller` is a natural transformation.
- `witt_vector.ghost_component_teichmuller`:
  the `n`-th ghost component of `witt_vector.teichmuller p r` is `r ^ p ^ n`.

-/

namespace witt_vector

/--
The underlying function of the monoid hom `witt_vector.teichmuller`.
The `0`-th coefficient of `teichmuller_fun p r` is `r`, and all others are `0`.
-/
def teichmuller_fun (p : ℕ) {R : Type u_1} [comm_ring R] (r : R) : witt_vector p R := sorry

/-!
## `teichmuller` is a monoid homomorphism

On ghost components, it is clear that `teichmuller_fun` is a monoid homomorphism.
But in general the ghost map is not injective.
We follow the same strategy as for proving that the the ring operations on `𝕎 R`
satisfy the ring axioms.

1. We first prove it for rings `R` where `p` is invertible,
   because then the ghost map is in fact an isomorphism.
2. After that, we derive the result for `mv_polynomial R ℤ`,
3. and from that we can prove the result for arbitrary `R`.
-/

/-- The Teichmüller lift of an element of `R` to `𝕎 R`.
The `0`-th coefficient of `teichmuller p r` is `r`, and all others are `0`.
This is a monoid homomorphism. -/
def teichmuller (p : ℕ) {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] :
    R →* witt_vector p R :=
  monoid_hom.mk (teichmuller_fun p) sorry sorry

@[simp] theorem teichmuller_coeff_zero (p : ℕ) {R : Type u_1} [hp : fact (nat.prime p)]
    [comm_ring R] (r : R) : coeff (coe_fn (teichmuller p) r) 0 = r :=
  rfl

@[simp] theorem teichmuller_coeff_pos (p : ℕ) {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R]
    (r : R) (n : ℕ) (hn : 0 < n) : coeff (coe_fn (teichmuller p) r) n = 0 :=
  sorry

@[simp] theorem teichmuller_zero (p : ℕ) {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] :
    coe_fn (teichmuller p) 0 = 0 :=
  sorry

/-- `teichmuller` is a natural transformation. -/
@[simp] theorem map_teichmuller (p : ℕ) {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)]
    [comm_ring R] [comm_ring S] (f : R →+* S) (r : R) :
    coe_fn (map f) (coe_fn (teichmuller p) r) = coe_fn (teichmuller p) (coe_fn f r) :=
  map_teichmuller_fun p f r

/-- The `n`-th ghost component of `teichmuller p r` is `r ^ p ^ n`. -/
@[simp] theorem ghost_component_teichmuller (p : ℕ) {R : Type u_1} [hp : fact (nat.prime p)]
    [comm_ring R] (r : R) (n : ℕ) :
    coe_fn (ghost_component n) (coe_fn (teichmuller p) r) = r ^ p ^ n :=
  ghost_component_teichmuller_fun p r n

end Mathlib


/-
Copyright (c) 2020 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis
-/

import data.int.cast.lemmas           -- used by clients
import data.int.char_zero
import tactic.norm_cast

/-!
# A tactic to shift `ℕ` goals to `ℤ`

It is often easier to work in `ℤ`, where subtraction is well behaved, than in `ℕ` where it isn't.
`zify` is a tactic that casts goals and hypotheses about natural numbers to ones about integers.
It makes use of `push_cast`, part of the `norm_cast` family, to simplify these goals.

## Implementation notes

`zify` is extensible, using the attribute `@[zify]` to label lemmas used for moving propositions
from `ℕ` to `ℤ`.
`zify` lemmas should have the form `∀ a₁ ... aₙ : ℕ, Pz (a₁ : ℤ) ... (aₙ : ℤ) ↔ Pn a₁ ... aₙ`.
For example, `int.coe_nat_le_coe_nat_iff : ∀ (m n : ℕ), ↑m ≤ ↑n ↔ m ≤ n` is a `zify` lemma.

`zify` is very nearly just `simp only with zify push_cast`. There are a few minor differences:
* `zify` lemmas are used in the opposite order of the standard simp form.
  E.g. we will rewrite with `int.coe_nat_le_coe_nat_iff` from right to left.
* `zify` should fail if no `zify` lemma applies (i.e. it was unable to shift any proposition to ℤ).
  However, once this succeeds, it does not necessarily need to rewrite with any `push_cast` rules.
-/

open tactic

namespace zify

/--
The `zify` attribute is used by the `zify` tactic. It applies to lemmas that shift propositions
between `nat` and `int`.

`zify` lemmas should have the form `∀ a₁ ... aₙ : ℕ, Pz (a₁ : ℤ) ... (aₙ : ℤ) ↔ Pn a₁ ... aₙ`.
For example, `int.coe_nat_le_coe_nat_iff : ∀ (m n : ℕ), ↑m ≤ ↑n ↔ m ≤ n` is a `zify` lemma.
-/
@[user_attribute]
meta def zify_attr : user_attribute simp_lemmas unit :=
{ name := `zify,
  descr := "Used to tag lemmas for use in the `zify` tactic",
  cache_cfg :=
    { mk_cache :=
        λ ns, mmap (λ n, do c ← mk_const n, return (c, tt)) ns >>= simp_lemmas.mk.append_with_symm,
      dependencies := [] } }

/--
Given an expression `e`, `lift_to_z e` looks for subterms of `e` that are propositions "about"
natural numbers and change them to propositions about integers.

Returns an expression `e'` and a proof that `e = e'`.

Includes `ge_iff_le` and `gt_iff_lt` in the simp set. These can't be tagged with `zify` as we
want to use them in the "forward", not "backward", direction.
-/
meta def lift_to_z (e : expr) : tactic (expr × expr) :=
do sl ← zify_attr.get_cache,
   sl ← sl.add_simp `ge_iff_le, sl ← sl.add_simp `gt_iff_lt,
   (e', prf, _) ← simplify sl [] e,
   return (e', prf)

attribute [zify] int.coe_nat_le_coe_nat_iff int.coe_nat_lt_coe_nat_iff int.coe_nat_eq_coe_nat_iff

end zify

@[zify] lemma int.coe_nat_ne_coe_nat_iff (a b : ℕ) : (a : ℤ) ≠ b ↔ a ≠ b :=
by simp

/--
`zify extra_lems e` is used to shift propositions in `e` from `ℕ` to `ℤ`.
This is often useful since `ℤ` has well-behaved subtraction.

The list of extra lemmas is used in the `push_cast` step.

Returns an expression `e'` and a proof that `e = e'`.-/
meta def tactic.zify (extra_lems : list simp_arg_type) : expr → tactic (expr × expr) := λ z,
do (z1, p1) ← zify.lift_to_z z <|> fail "failed to find an applicable zify lemma",
   (z2, p2) ← norm_cast.derive_push_cast extra_lems z1,
   prod.mk z2 <$> mk_eq_trans p1 p2

/--
A variant of `tactic.zify` that takes `h`, a proof of a proposition about natural numbers,
and returns a proof of the zified version of that propositon.
-/
meta def tactic.zify_proof (extra_lems : list simp_arg_type) (h : expr) : tactic expr :=
do (_, pf) ← infer_type h >>= tactic.zify extra_lems,
   mk_eq_mp pf h

section

setup_tactic_parser

/--
The `zify` tactic is used to shift propositions from `ℕ` to `ℤ`.
This is often useful since `ℤ` has well-behaved subtraction.

```lean
example (a b c x y z : ℕ) (h : ¬ x*y*z < 0) : c < a + 3*b :=
begin
  zify,
  zify at h,
  /-
  h : ¬↑x * ↑y * ↑z < 0
  ⊢ ↑c < ↑a + 3 * ↑b
  -/
end
```

`zify` can be given extra lemmas to use in simplification. This is especially useful in the
presence of nat subtraction: passing `≤` arguments will allow `push_cast` to do more work.
```
example (a b c : ℕ) (h : a - b < c) (hab : b ≤ a) : false :=
begin
  zify [hab] at h,
  /- h : ↑a - ↑b < ↑c -/
end
```

`zify` makes use of the `@[zify]` attribute to move propositions,
and the `push_cast` tactic to simplify the `ℤ`-valued expressions.

`zify` is in some sense dual to the `lift` tactic. `lift (z : ℤ) to ℕ` will change the type of an
integer `z` (in the supertype) to `ℕ` (the subtype), given a proof that `z ≥ 0`;
propositions concerning `z` will still be over `ℤ`. `zify` changes propositions about `ℕ` (the
subtype) to propositions about `ℤ` (the supertype), without changing the type of any variable.
-/
meta def tactic.interactive.zify (sl : parse simp_arg_list) (l : parse location) : tactic unit :=
do locs ← l.get_locals,
replace_at (tactic.zify sl) locs l.include_goal >>= guardb

end

add_tactic_doc
{ name := "zify",
  category := doc_category.attr,
  decl_names := [`zify.zify_attr],
  tags := ["coercions", "transport"] }

add_tactic_doc
{ name := "zify",
  category := doc_category.tactic,
  decl_names := [`tactic.interactive.zify],
  tags := ["coercions", "transport"] }


/-
Copyright (c) 2022 Jun Yoshida. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
-/

import Dijkstra.Control.Monad.Rel

/-!

# Specification Monads

(based on [Dijkstra Mondads for All](https://arxiv.org/abs/1903.01237) by K. Maillard, D. Ahman, R. Atkey, G. Martinez, C. Hritcu, E. Rivas, É. Tanter)

A ***specification*** monad is a monad that is used to represent pre/post-conditions of computation.
It is usually associated to a specific monad that provides actual computation semantics.

The idea is based on the notion of ***predicate transformer*** introduced by Dijkstra in the paper *"Guarded commands, nondeterminacy and formal derivation of programs"*.
For example, a specification monad `WPPure` for the monad `Id`, which is the "pure computation", is as follows:

```lean
WPPure α ≡ {wp : (α → Prop) → Prop // ∀ (p q : α → Prop), (∀ a, p a → q a) → wp p → wp q}
```

Indeed, it (coherently) transforms a post-condition `p : α → Prop` into the *weakest precondition* `wp p : Prop` which ensures `p` after computation.

In spite of the origin of the notion, not all specification monads are of this form.
Actually, we call a monad `m` a specification monad provided it is equipped with a ***monadic relation***; e.g. a relation on each `m α` which is respected by `pure` and `bind`.
For example, the specification monad `WPPure` above has a canonical order so that, for `x y : WPPure α`,

```lean
x ≤ y ≡ ∀ (p : α → Prop), y p → x p
```

In other words, `x ≤ y` means that `y` requires a stronger pre-condition than `x` does.
For more details on monadic relations, see [Rel.lean](Dijkstra/Control/Monad/Rel.lean).

-/

universe u v w

/-!

## Definition of specification monads

-/

/-- `SpecMonad` is a monad which is equipped with a transitive monadic relation. -/
class SpecMonad (m : Type u → Type v) [Monad m] where
  rel : MonadRel m m
  trans {α : Type u} {x y z : m α} : rel.rel x y → rel.rel y z → rel.rel x z

def mrel {m : Type u → Type v} [Monad m] [self : SpecMonad m] {α : Type u} : m α → m α → Prop :=
  self.rel.rel

theorem mrel_pure {m : Type u → Type v} [Monad m] [self : SpecMonad m] {α : Type u} (a : α) : mrel (m:=m) (pure a) (pure a) :=
  self.rel.pure a

theorem mrel_bind {m : Type u → Type v} [Monad m] [self : SpecMonad m] {α β : Type u} {x y : m α} {f g : α → m β} : mrel x y → (∀ a, mrel (f a) (g a)) → mrel (x >>= f) (y >>= g) :=
  self.rel.bind

theorem mrel_trans {m : Type u → Type v} [Monad m] [self : SpecMonad m] {α : Type u} {x y z : m α} : mrel x y → mrel y z → mrel x z :=
  self.trans

instance {m : Type u → Type v} [Monad m] [SpecMonad m] {α : Type u} : Trans (mrel (m:=m) (α:=α)) (mrel (m:=m)) (mrel (m:=m)) where
  trans := mrel_trans

/-!

## Examples of specification monads

-/

/-!
### Predicate monad

For `α : Type u`, `Pred α = α → Prop` is the type of predicates on the terms of `α`.
As it is identified with the set of subtypes of `α`, `Pred` can also be seen as the (covariant) power-set operator and hence admits a canonical structure of a monad.
The `pure : α → Pred α` forms a singleton subtype, and the `bind : Pred α → (α → Pred β) → Pred β` takes the union of an `α`-indexed subtype-family over a subset.
In terms of predicates, `(p >>= q) b` holds precisely if there is a term `a : α` such that both `p a` and `q a b` are satisfied.

-/

def Pred (α : Type u) : Type u := α → Prop

/-- Equality of `Pred α` from `funext` and `propext`. -/
protected
def Pred.ext {α : Type u} {p q : Pred α} : (∀ a, p a ↔ q a) → p = q :=
  λ hpq => funext (λ a => propext (hpq a))

instance instMonadPred : Monad Pred where
  pure a := Eq a
  bind p f := λ b => ∃ a, p a ∧ f a b

instance instLawfulMonadPred : LawfulMonad Pred where
  map_const := rfl
  id_map p := by
    funext a; dsimp [Functor.map]
    apply propext
    constructor
    case mp =>
      intro h; cases h with | intro a ha => exact ha.2 ▸ ha.1
    case mpr =>
      intro h; exists a
  seqLeft_eq p q := by
    dsimp [Seq.seq, SeqLeft.seqLeft, Functor.map]
    funext a; apply propext
    constructor
    case mp =>
      intro h; cases h with | intro a₁ ha₁ =>
      exists (λ _ => a₁)
      exact ⟨Exists.intro a₁ ⟨ha₁.left, rfl⟩, ha₁.right⟩
    case mpr =>
      intro h; cases h with | intro f hf =>
      cases hf.left with | intro a₁ ha₁ =>
      rw [←ha₁.right] at hf
      exact Exists.intro a₁ $ ⟨ha₁.left, hf.right⟩
  seqRight_eq p q := by
    dsimp [SeqRight.seqRight, Seq.seq, Functor.map]
    funext b; apply propext
    constructor
    case mp =>
      intro h; cases h with | intro a ha =>
      exists id
      exact And.intro ⟨a, ⟨ha.left, rfl⟩⟩ ⟨b, ⟨ha.right, rfl⟩⟩
    case mpr =>
      intro h; cases h with | intro f hf =>
      cases hf.left with | intro a ha =>
      cases hf.right with | intro b₁ hb₁ =>
      cases hb₁.right
      rw [←ha.right] at *
      exact ⟨a, ⟨ha.left, hb₁.left⟩⟩
  pure_seq f p := by
    dsimp [Seq.seq, Pure.pure, Functor.map]
    funext b; apply propext
    constructor
    case mp =>
      intro h; cases h with | intro f₁ hf₁ =>
      cases hf₁.left.symm
      exact hf₁.right
    case mpr =>
      intro h; exact ⟨f, ⟨rfl, h⟩⟩
  bind_pure_comp f p := rfl
  bind_map p q := rfl
  pure_bind a f := by
    dsimp [pure, bind]
    funext b; apply propext
    constructor
    case mp =>
      intro h; cases h with | intro a ha =>
      rw [ha.left]; exact ha.right
    case mpr =>
      intro hf
      exact ⟨a, ⟨rfl, hf⟩⟩
  bind_assoc p f g := by
    dsimp [bind]
    funext b; apply propext
    constructor
    case mp =>
      intro h; cases h with | intro b₁ hb₁ =>
      cases hb₁.left with | intro a ha =>
      exists a; apply And.intro ha.left ⟨b₁, ⟨ha.right, hb₁.right⟩⟩
    case mpr =>
      intro h; cases h with | intro a ha =>
      cases ha.right with | intro b₁ hb₁ =>
      exists b₁
      exact And.intro ⟨a, ⟨ha.left, hb₁.left⟩⟩ hb₁.right

/-- The power-set `Pred α` is ordered by inclusion. In terms of predicates, the order agrees with the "implication". -/
protected
def Pred.rel : MonadRel Pred Pred where
  rel p q := ∀ a, p a → q a
  pure a := by dsimp [Pure.pure]; intro _; exact id
  bind := by
    intro _ _ p q f g hpq hfg b hb
    dsimp [bind] at *
    cases hb with | intro a ha =>
    exists a
    exact ⟨hpq a ha.left, hfg a b ha.right⟩

instance instSpecMonad : SpecMonad Pred where
  rel := Pred.rel
  trans hpq hqr := λ a hp => hqr a (hpq a hp)

/-!
### Weakest predicate for pure computations
-/

structure WPPure (α : Type u) where
  predT : (α → Prop) → Prop
  monotonic {p q : α → Prop} (h : ∀ a, p a → q a) : predT p → predT q

instance coeWPPurePredT (α :Type u) : CoeFun (WPPure α) (λ _ => (α → Prop) → Prop) where
  coe wp := wp.predT

/-- A utility lemma to prove equality on `WPPure α`. -/
protected
theorem WPPure.eq {α : Type u} : ∀ {wp wq : WPPure α}, wp.predT = wq.predT → wp = wq
| mk _ _, mk _ _, rfl => rfl

/-- Equality on `WPPure α` from `funext` and `propext`. -/
protected
theorem WPPure.ext {α : Type u} {wp wq : WPPure α} : (∀ (p : α → Prop), wp.predT p ↔ wq.predT p) → wp = wq :=
  λ hpq => WPPure.eq $ funext λ p => propext (hpq p)

instance instMonadWPPure : Monad WPPure where
  pure a := {
    predT := λ p => p a
    monotonic := by
      intro p q hpq hpa
      exact hpq a hpa
  }
  bind x f := {
    predT := λ p => x.predT (λ a => (f a).predT p)
    monotonic := by
      intro p q hpq hxp
      exact x.monotonic (λ a => (f a).monotonic hpq) hxp
  }

instance instLawfulMonadWPPure : LawfulMonad WPPure where
  map_const := rfl
  id_map _ := rfl
  seqLeft_eq _ _ := rfl
  seqRight_eq _ _ := rfl
  pure_seq _ _ := rfl
  bind_pure_comp _ _ := rfl
  bind_map _ _ := rfl
  pure_bind _ _ := rfl
  bind_assoc _ _ _ := rfl

protected
def WPPure.rel : MonadRel WPPure WPPure where
  rel x y := ∀ p, y.predT p → x.predT p
  pure a := by dsimp; intro _; exact id
  bind := by
    dsimp [bind]; intro _ _ x y f g hxy hfg hb p
    apply hxy
    exact y.monotonic (λ a => hfg a hb) p

instance instSpecMonadWPPure : SpecMonad WPPure where
  rel := WPPure.rel
  trans hxy hyz := λ p hz => hxy p (hyz p hz)

/-!

## Relations between specification monads

For monadic relations between specification monads, we assume compatibility with the intrinsic relations in addition to compatibility with monadic structures.

-/

structure SpecMonadRel (m : Type u → Type v) [Monad m] [SpecMonad m] (n : Type u → Type w) [Monad n] [SpecMonad n] extends MonadRel m n where
  trans_left {α : Type u} {mx my : m α} {nz : n α} : mrel mx my → rel my nz → rel mx nz
  trans_right {α : Type u} {mx : m α} {ny nz : n α} : rel mx ny → mrel ny nz → rel mx nz

def WPPure.validate : SpecMonadRel WPPure Pred where
  rel wp p := wp.predT p
  pure a := rfl
  bind {α} {β} wa pa wf pf hwp hf := by
    dsimp [bind] at *
    apply wa.monotonic (p:=pa) _ hwp
    intro a ha
    apply (wf a).monotonic _ (hf a)
    intro b hb
    exact ⟨a, ⟨ha, hb⟩⟩
  trans_left := by
    dsimp [mrel, SpecMonad.rel, WPPure.rel]
    intro α wx wy p hxy hp
    exact hxy p hp
  trans_right := by
    dsimp [mrel, SpecMonad.rel, Pred.rel]
    intro α wx p q hp hpq
    exact wx.monotonic hpq hp


import .logic .comb
open set classical

namespace finset

variable {A : Type}
variable [deceq : decidable_eq A]

definition to_set (s : finset A) : set A := λx, x ∈ s

-- def ts := @to_set A
instance finset_to_set_coe : has_coe (finset A) (set A) := ⟨to_set⟩

variables (s t : finset A) (x y : A)

theorem mem_eq_mem_to_set : x ∈ s = (x ∈ to_set s) := rfl

definition to_set.inj {s₁ s₂ : finset A} : to_set s₁ = to_set s₂ → s₁ = s₂ :=
λ h, ext (λ a, iff.of_eq (calc
  (a ∈ s₁) = (a ∈ to_set s₁) : mem_eq_mem_to_set _ _
       ... = (a ∈ to_set s₂) : by rw -h
       ... = (a ∈ s₂) : mem_eq_mem_to_set _ _))

-- A example
theorem mem_to_set_empty : (set.mem x (to_set empty)) = (mem x empty) := rfl
theorem to_set_empty : to_set empty = (∅:set A) := rfl

-- theorem mem_to_set_univ [h : fintype A] : (x ∈ to_set univ) = (x ∈ set.univ) :=
--   propext (iff.intro (assume H, trivial) (assume H, !mem_univ))
-- theorem to_set_univ [h : fintype A] : to_set univ = (set.univ : set A) := funext (λ x, !mem_to_set_univ)

-- instance : has_subset (finset A) := ⟨finset.subset⟩

theorem mem_to_set_upto (x n : ℕ) : x ∈ to_set (upto n) = (x ∈ {a | a < n}) := mem_upto_eq _ _
theorem to_set_upto (n : ℕ) : to_set (upto n) = {a | a < n} := funext (λ x, mem_to_set_upto _ _)

include deceq

theorem mem_to_set_insert : x ∈ insert y s = (x ∈ set.insert y s) := mem_insert_eq _ _ _

theorem to_set_insert : (set.insert y (to_set s)) = to_set (insert y s) := funext (λ x, eq.symm (mem_to_set_insert _ _ _))

theorem mem_to_set_union : x ∈ s ∪ t = (x ∈ to_set s ∪ to_set t) := mem_union_eq _ _ _
theorem to_set_union : to_set (s ∪ t) = to_set s ∪ to_set t := funext (λ x, mem_to_set_union _ _ _)

theorem mem_to_set_inter : x ∈ s ∩ t = (x ∈ to_set s ∩ to_set t) := mem_inter_eq _ _ _
theorem to_set_inter : to_set (s ∩ t) = to_set s ∩ to_set t := funext (λ x, mem_to_set_inter _ _ _)

theorem mem_to_set_diff : x ∈ s \ t = (x ∈ to_set s \ to_set t) := mem_diff_eq _ _ _
theorem to_set_diff : to_set (s \ t) = to_set s \ to_set t := funext (λ x, mem_to_set_diff _ _ _)

theorem mem_to_set_sep (p : A → Prop) [h : decidable_pred p] : x ∈ sep p s = (x ∈ set.sep p s) :=
  finset.mem_sep_eq _ _
theorem to_set_sep (p : A → Prop) [h : decidable_pred p] : to_set (sep p s) = set.sep p (to_set s) :=
  funext (λ x, mem_to_set_sep _ _ _)

theorem mem_to_set_image {B : Type} [h : decidable_eq B] (f : A → B) {s : finset A} {y : B} :
  y ∈ image f s = (y ∈ set.image f s) := mem_image_eq _
theorem to_set_image {B : Type} [h : decidable_eq B] (f : A → B) (s : finset A) :
to_set (image f s) = set.image f (to_set s) := funext (λ x, mem_to_set_image _)

/- relations -/

attribute [instance]
definition decidable_mem_to_set (x : A) (s : finset A) : decidable (x ∈ to_set s) :=
decidable_of_decidable_of_eq (decidable_mem _ _) (mem_eq_mem_to_set _ _)

theorem eq_of_to_set_eq_to_set {s t : finset A} (H : to_set s =  to_set t) : s = t :=
to_set.inj H

theorem eq_eq_to_set_eq : (s = t) = (to_set s = to_set t) :=
propext (iff.intro (assume H, H ▸ rfl) eq_of_to_set_eq_to_set)

-- #check quot.has_decidable_eq

attribute [instance]
definition decidable_to_set_eq (s t : finset A) : decidable (to_set s = to_set t) :=
decidable_of_decidable_of_eq (has_decidable_eq _ _) (eq_eq_to_set_eq _ _)

theorem subset_eq_to_set_subset (s t : finset A) : (s ⊆ t) = (to_set s ⊆ to_set t) :=
propext (iff.intro
  (assume H, take x xs, mem_of_subset_of_mem H xs)
  (assume H, subset_of_forall H))

-- attribute [instance]
-- definition decidable_subset [h : decidable_eq A] : ∀ (s t: finset A), decidable (s ⊆ t) :=
-- sorry

-- definition decidable_to_set_subset (s t : finset A) : decidable (to_set s ⊆ to_set t) :=
-- decidable_of_decidable_of_eq (decidable_subset _ _) (subset_eq_to_set_subset _ _)

/- bounded quantifiers -/

-- definition decidable_bounded_forall (s : finset A) (p : A → Prop) [h : decidable_pred p] :
--   decidable (∀ x ∈ to_set s, p x) :=
-- decidable_of_decidable_of_iff _ !all_iff_forall

-- definition decidable_bounded_existo_set (s : finset A) (p : A → Prop) [h : decidable_pred p] :
--   decidable (∃₀ x ∈ to_set s, p x) :=
-- decidable_of_decidable_of_iff _ !any_iff_exists

/- properties -/

-- theorem inj_on_to_set {B : Type} [h : decidable_eq B] (f : A → B) (s : finset A) :
--   inj_on f s = inj_on f (to_set s) :=
-- rfl

end finset


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

/-!
# Isomorphisms about functors which preserve (co)limits

If `G` preserves limits, and `C` and `D` have limits, then for any diagram `F : J ⥤ C` we have a
canonical isomorphism `preserves_limit_iso : G.obj (limit F) ≅ limit (F ⋙ G)`.
We also show that we can commute `is_limit.lift` of a preserved limit with `functor.map_cone`:
`(preserves_limit.preserves t).lift (G.map_cone c₂) = G.map (t.lift c₂)`.

The duals of these are also given. For functors which preserve (co)limits of specific shapes, see
`preserves/shapes.lean`.
-/

universes w' w v₁ v₂ u₁ u₂

noncomputable theory

namespace category_theory

open category limits

variables {C : Type u₁} [category.{v₁} C]
variables {D : Type u₂} [category.{v₂} D]
variables (G : C ⥤ D)
variables {J : Type w} [category.{w'} J]
variables (F : J ⥤ C)

section
variables [preserves_limit F G]

@[simp]
lemma preserves_lift_map_cone (c₁ c₂ : cone F) (t : is_limit c₁) :
  (preserves_limit.preserves t).lift (G.map_cone c₂) = G.map (t.lift c₂) :=
((preserves_limit.preserves t).uniq (G.map_cone c₂) _ (by simp [← G.map_comp])).symm

variables [has_limit F] [has_limit (F ⋙ G)]
/--
If `G` preserves limits, we have an isomorphism from the image of the limit of a functor `F`
to the limit of the functor `F ⋙ G`.
-/
def preserves_limit_iso : G.obj (limit F) ≅ limit (F ⋙ G) :=
(preserves_limit.preserves (limit.is_limit _)).cone_point_unique_up_to_iso (limit.is_limit _)

@[simp, reassoc]
lemma preserves_limits_iso_hom_π (j) :
  (preserves_limit_iso G F).hom ≫ limit.π _ j = G.map (limit.π F j) :=
is_limit.cone_point_unique_up_to_iso_hom_comp _ _ j

@[simp, reassoc]
lemma preserves_limits_iso_inv_π (j) :
  (preserves_limit_iso G F).inv ≫ G.map (limit.π F j) = limit.π _ j :=
is_limit.cone_point_unique_up_to_iso_inv_comp _ _ j

@[simp, reassoc]
lemma lift_comp_preserves_limits_iso_hom (t : cone F) :
  G.map (limit.lift _ t) ≫ (preserves_limit_iso G F).hom = limit.lift (F ⋙ G) (G.map_cone _) :=
by { ext, simp [← G.map_comp] }

variables [preserves_limits_of_shape J G] [has_limits_of_shape J D] [has_limits_of_shape J C]

/-- If `C, D` has all limits of shape `J`, and `G` preserves them, then `preserves_limit_iso` is
functorial wrt `F`. -/
@[simps] def preserves_limit_nat_iso : lim ⋙ G ≅ (whiskering_right J C D).obj G ⋙ lim :=
nat_iso.of_components (λ F, preserves_limit_iso G F)
begin
  intros _ _ f,
  ext,
  dsimp,
  simp only [preserves_limits_iso_hom_π, whisker_right_app, lim_map_π, category.assoc,
    preserves_limits_iso_hom_π_assoc, ← G.map_comp]
end

end

section
variables [preserves_colimit F G]

@[simp]
lemma preserves_desc_map_cocone (c₁ c₂ : cocone F) (t : is_colimit c₁) :
  (preserves_colimit.preserves t).desc (G.map_cocone _) = G.map (t.desc c₂) :=
((preserves_colimit.preserves t).uniq (G.map_cocone _) _ (by simp [← G.map_comp])).symm

variables [has_colimit F] [has_colimit (F ⋙ G)]
/--
If `G` preserves colimits, we have an isomorphism from the image of the colimit of a functor `F`
to the colimit of the functor `F ⋙ G`.
-/
-- TODO: think about swapping the order here
def preserves_colimit_iso : G.obj (colimit F) ≅ colimit (F ⋙ G) :=
(preserves_colimit.preserves (colimit.is_colimit _)).cocone_point_unique_up_to_iso
  (colimit.is_colimit _)

@[simp, reassoc]
lemma ι_preserves_colimits_iso_inv (j : J) :
  colimit.ι _ j ≫ (preserves_colimit_iso G F).inv = G.map (colimit.ι F j) :=
is_colimit.comp_cocone_point_unique_up_to_iso_inv _ (colimit.is_colimit (F ⋙ G)) j

@[simp, reassoc]
lemma ι_preserves_colimits_iso_hom (j : J) :
  G.map (colimit.ι F j) ≫ (preserves_colimit_iso G F).hom = colimit.ι (F ⋙ G) j :=
(preserves_colimit.preserves (colimit.is_colimit _)).comp_cocone_point_unique_up_to_iso_hom _ j

@[simp, reassoc]
lemma preserves_colimits_iso_inv_comp_desc (t : cocone F) :
  (preserves_colimit_iso G F).inv ≫ G.map (colimit.desc _ t) = colimit.desc _ (G.map_cocone t) :=
by { ext, simp [← G.map_comp] }

variables [preserves_colimits_of_shape J G] [has_colimits_of_shape J D] [has_colimits_of_shape J C]

/-- If `C, D` has all colimits of shape `J`, and `G` preserves them, then `preserves_colimit_iso`
is functorial wrt `F`. -/
@[simps] def preserves_colimit_nat_iso : colim ⋙ G ≅ (whiskering_right J C D).obj G ⋙ colim :=
nat_iso.of_components (λ F, preserves_colimit_iso G F)
begin
  intros _ _ f,
  rw [← iso.inv_comp_eq, ← category.assoc, ← iso.eq_comp_inv],
  ext,
  dsimp,
  erw ι_colim_map_assoc,
  simp only [ι_preserves_colimits_iso_inv, whisker_right_app, category.assoc,
    ι_preserves_colimits_iso_inv_assoc, ← G.map_comp],
  erw ι_colim_map
end

end

end category_theory